summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <dkf@noemail.net>2012-07-16 12:36:40 (GMT)
committerdkf <dkf@noemail.net>2012-07-16 12:36:40 (GMT)
commit5c569203bdf540f4fdc9fc63379c3c630866731d (patch)
tree83188d92aa77a52a178e0ae85ba5439c402f4eca
parent671fa12fa3a02c014800a309a90d4ea311d7e5bb (diff)
downloadtk-5c569203bdf540f4fdc9fc63379c3c630866731d.zip
tk-5c569203bdf540f4fdc9fc63379c3c630866731d.tar.gz
tk-5c569203bdf540f4fdc9fc63379c3c630866731d.tar.bz2
Working towards adding all the Tcl_SetErrorCode calls that should be there.
** WORK IN PROGRESS ** FossilOrigin-Name: 6f8f9336c381b81bbe323a8399eaf4dd3f89b34f
-rw-r--r--carbon/tkMacOSXWindowEvent.c7
-rw-r--r--generic/tk3d.c9
-rw-r--r--generic/tkArgv.c79
-rw-r--r--generic/tkBind.c25
-rw-r--r--generic/tkBitmap.c4
-rw-r--r--generic/tkBusy.c1
-rw-r--r--generic/tkCanvArc.c30
-rw-r--r--generic/tkCanvBmap.c18
-rw-r--r--generic/tkCanvImg.c22
-rw-r--r--generic/tkCanvLine.c98
-rw-r--r--generic/tkCanvPs.c8
-rw-r--r--generic/tkCanvWind.c23
-rw-r--r--generic/tkColor.c10
-rw-r--r--generic/tkConfig.c28
-rw-r--r--generic/tkEntry.c16
-rw-r--r--generic/tkFont.c10
-rw-r--r--generic/tkGrab.c52
-rw-r--r--generic/tkGrid.c36
-rw-r--r--generic/tkImage.c4
-rw-r--r--generic/tkImgBmap.c9
-rw-r--r--generic/tkImgGIF.c20
-rw-r--r--generic/tkImgPNG.c117
-rw-r--r--generic/tkImgPPM.c8
-rw-r--r--generic/tkImgPhoto.c70
-rw-r--r--generic/tkListbox.c156
-rw-r--r--generic/tkObj.c6
-rw-r--r--generic/tkOldConfig.c42
-rw-r--r--generic/tkOption.c31
-rw-r--r--generic/tkPack.c24
-rw-r--r--generic/tkPlace.c3
-rw-r--r--generic/tkRectOval.c6
-rw-r--r--generic/tkStubInit.c4
-rw-r--r--generic/tkStyle.c1
-rw-r--r--generic/tkUtil.c14
-rw-r--r--generic/tkVisual.c5
-rw-r--r--generic/tkWindow.c158
-rw-r--r--macosx/tkMacOSXWindowEvent.c7
-rw-r--r--macosx/tkMacOSXWm.c115
-rw-r--r--unix/tkUnix.c34
-rw-r--r--unix/tkUnixSelect.c38
-rw-r--r--unix/tkUnixWm.c178
-rw-r--r--win/tkWinDialog.c6
-rw-r--r--win/tkWinSend.c114
-rw-r--r--win/tkWinSendCom.c102
-rw-r--r--win/tkWinSendCom.h6
-rw-r--r--win/tkWinX.c9
46 files changed, 1006 insertions, 757 deletions
diff --git a/carbon/tkMacOSXWindowEvent.c b/carbon/tkMacOSXWindowEvent.c
index 2f46026..99ab918 100644
--- a/carbon/tkMacOSXWindowEvent.c
+++ b/carbon/tkMacOSXWindowEvent.c
@@ -885,10 +885,9 @@ TkWmProtocolEventProc(
Tcl_Preserve(interp);
result = Tcl_GlobalEval(interp, protPtr->command);
if (result != TCL_OK) {
- Tcl_AddErrorInfo(interp, "\n (command for \"");
- Tcl_AddErrorInfo(interp,
- Tk_GetAtomName((Tk_Window) winPtr, protocol));
- Tcl_AddErrorInfo(interp, "\" window manager protocol)");
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (command for \"%s\" window manager protocol)",
+ Tk_GetAtomName((Tk_Window) winPtr, protocol)));
Tcl_BackgroundException(interp, result);
}
Tcl_Release(interp);
diff --git a/generic/tk3d.c b/generic/tk3d.c
index 2920c76..dd7ab2f 100644
--- a/generic/tk3d.c
+++ b/generic/tk3d.c
@@ -673,11 +673,10 @@ Tk_GetRelief(
} else if ((c == 's') && (strncmp(name, "sunken", length) == 0)) {
*reliefPtr = TK_RELIEF_SUNKEN;
} else {
- char buf[200];
-
- sprintf(buf, "bad relief \"%.50s\": must be %s",
- name, "flat, groove, raised, ridge, solid, or sunken");
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp,
+ Tcl_ObjPrintf("bad relief \"%.50s\": must be %s",
+ name, "flat, groove, raised, ridge, solid, or sunken"));
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "RELIEF", NULL);
return TCL_ERROR;
}
return TCL_OK;
diff --git a/generic/tkArgv.c b/generic/tkArgv.c
index 3f235ad..f4ddda4 100644
--- a/generic/tkArgv.c
+++ b/generic/tkArgv.c
@@ -70,7 +70,7 @@ Tk_ParseArgv(
register const Tk_ArgvInfo *infoPtr;
/* Pointer to the current entry in the table
* of argument descriptions. */
- const Tk_ArgvInfo *matchPtr; /* Descriptor that matches current argument. */
+ const Tk_ArgvInfo *matchPtr;/* Descriptor that matches current argument. */
const char *curArg; /* Current argument */
register char c; /* Second character of current arg (used for
* quick check for matching; use 2nd char.
@@ -83,6 +83,7 @@ Tk_ParseArgv(
* than srcIndex). */
int argc; /* # arguments in argv still to process. */
size_t length; /* Number of characters in current argument. */
+ char *endPtr; /* Used for identifying junk in arguments. */
int i;
if (flags & TK_ARGV_DONT_SKIP_FIRST_ARG) {
@@ -139,8 +140,9 @@ Tk_ParseArgv(
continue;
}
if (matchPtr != NULL) {
- Tcl_AppendResult(interp, "ambiguous option \"", curArg,
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "ambiguous option \"%s\"", curArg));
+ Tcl_SetErrorCode(interp, "TK", "ARG", "AMBIGUOUS", NULL);
return TCL_ERROR;
}
matchPtr = infoPtr;
@@ -153,8 +155,9 @@ Tk_ParseArgv(
*/
if (flags & TK_ARGV_NO_LEFTOVERS) {
- Tcl_AppendResult(interp, "unrecognized argument \"",
- curArg, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unrecognized argument \"%s\"", curArg));
+ Tcl_SetErrorCode(interp, "TK", "ARG", "UNRECOGNIZED", NULL);
return TCL_ERROR;
}
argv[dstIndex] = curArg;
@@ -175,19 +178,17 @@ Tk_ParseArgv(
case TK_ARGV_INT:
if (argc == 0) {
goto missingArg;
- } else {
- char *endPtr;
-
- *((int *) infoPtr->dst) = strtol(argv[srcIndex], &endPtr, 0);
- if ((endPtr == argv[srcIndex]) || (*endPtr != 0)) {
- Tcl_AppendResult(interp,"expected integer argument for \"",
- infoPtr->key, "\" but got \"", argv[srcIndex],
- "\"", NULL);
- return TCL_ERROR;
- }
- srcIndex++;
- argc--;
}
+ *((int *) infoPtr->dst) = strtol(argv[srcIndex], &endPtr, 0);
+ if ((endPtr == argv[srcIndex]) || (*endPtr != 0)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected %s argument for \"%s\" but got \"%s\"",
+ "integer", infoPtr->key, argv[srcIndex]));
+ Tcl_SetErrorCode(interp, "TK", "ARG", "INTEGER", NULL);
+ return TCL_ERROR;
+ }
+ srcIndex++;
+ argc--;
break;
case TK_ARGV_STRING:
if (argc == 0) {
@@ -211,19 +212,17 @@ Tk_ParseArgv(
case TK_ARGV_FLOAT:
if (argc == 0) {
goto missingArg;
- } else {
- char *endPtr;
-
- *((double *) infoPtr->dst) = strtod(argv[srcIndex], &endPtr);
- if ((endPtr == argv[srcIndex]) || (*endPtr != 0)) {
- Tcl_AppendResult(interp, "expected floating-point ",
- "argument for \"", infoPtr->key, "\" but got \"",
- argv[srcIndex], "\"", NULL);
- return TCL_ERROR;
- }
- srcIndex++;
- argc--;
}
+ *((double *) infoPtr->dst) = strtod(argv[srcIndex], &endPtr);
+ if ((endPtr == argv[srcIndex]) || (*endPtr != 0)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected %s argument for \"%s\" but got \"%s\"",
+ "floating-point", infoPtr->key, argv[srcIndex]));
+ Tcl_SetErrorCode(interp, "TK", "ARG", "FLOAT", NULL);
+ return TCL_ERROR;
+ }
+ srcIndex++;
+ argc--;
break;
case TK_ARGV_FUNC: {
typedef int (ArgvFunc)(char *, const char *, const char *);
@@ -249,6 +248,7 @@ Tk_ParseArgv(
}
case TK_ARGV_HELP:
PrintUsage(interp, argTable, flags);
+ Tcl_SetErrorCode(interp, "TK", "ARG", "HELP", NULL);
return TCL_ERROR;
case TK_ARGV_CONST_OPTION:
Tk_AddOption(tkwin, infoPtr->dst, infoPtr->src,
@@ -265,8 +265,10 @@ Tk_ParseArgv(
break;
case TK_ARGV_OPTION_NAME_VALUE:
if (argc < 2) {
- Tcl_AppendResult(interp, "\"", curArg,
- "\" option requires two following arguments", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" option requires two following arguments",
+ curArg));
+ Tcl_SetErrorCode(interp, "TK", "ARG", "NAME_VALUE", NULL);
return TCL_ERROR;
}
Tk_AddOption(tkwin, argv[srcIndex], argv[srcIndex+1],
@@ -274,14 +276,12 @@ Tk_ParseArgv(
srcIndex += 2;
argc -= 2;
break;
- default: {
- char buf[64 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "bad argument type %d in Tk_ArgvInfo", infoPtr->type);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ default:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad argument type %d in Tk_ArgvInfo", infoPtr->type));
+ Tcl_SetErrorCode(interp, "TK", "ARG", "BAD_TYPE", NULL);
return TCL_ERROR;
}
- }
}
/*
@@ -301,8 +301,9 @@ Tk_ParseArgv(
return TCL_OK;
missingArg:
- Tcl_AppendResult(interp, "\"", curArg,
- "\" option requires an additional argument", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" option requires an additional argument", curArg));
+ Tcl_SetErrorCode(interp, "TK", "ARG", "MISSING", NULL);
return TCL_ERROR;
}
diff --git a/generic/tkBind.c b/generic/tkBind.c
index e58ad4d..0c50368 100644
--- a/generic/tkBind.c
+++ b/generic/tkBind.c
@@ -2926,6 +2926,7 @@ HandleEventGenerate(
|| (mainPtr->mainPtr != ((TkWindow *) tkwin)->mainPtr)) {
Tcl_AppendResult(interp, "window id \"", Tcl_GetString(objv[0]),
"\" doesn't exist in this application", NULL);
+ Tcl_SetErrorCode(interp, "TK", "EVENT", "FOREIGN_TARGET", NULL);
return TCL_ERROR;
}
@@ -2941,11 +2942,13 @@ HandleEventGenerate(
if (count != 1) {
Tcl_SetResult(interp, "Double or Triple modifier not allowed",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "EVENT", "BAD_MODIFIER", NULL);
return TCL_ERROR;
}
if (*p != '\0') {
Tcl_SetResult(interp, "only one event specification allowed",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "EVENT", "MULTIPLE", NULL);
return TCL_ERROR;
}
@@ -3023,6 +3026,7 @@ HandleEventGenerate(
Tcl_AppendResult(interp, "value for \"", Tcl_GetString(optionPtr),
"\" missing", NULL);
+ Tcl_SetErrorCode(interp, "TK", "EVENT", "MISSING_VALUE", NULL);
return TCL_ERROR;
}
@@ -3165,6 +3169,7 @@ HandleEventGenerate(
if (keysym == NoSymbol) {
Tcl_AppendResult(interp, "unknown keysym \"", value, "\"",
NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "KEYSYM", NULL);
return TCL_ERROR;
}
@@ -3172,6 +3177,7 @@ HandleEventGenerate(
if (event.general.xkey.keycode == 0) {
Tcl_AppendResult(interp, "no keycode for keysym \"", value,
"\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "KEYCODE", NULL);
return TCL_ERROR;
}
if (!(flags & KEY)
@@ -3402,6 +3408,7 @@ HandleEventGenerate(
badopt:
Tcl_AppendResult(interp, name, " event doesn't accept \"",
Tcl_GetString(optionPtr), "\" option", NULL);
+ Tcl_SetErrorCode(interp, "TK", "EVENT", "BAD_OPTION", NULL);
return TCL_ERROR;
}
@@ -3496,6 +3503,7 @@ NameToWindow(
badWindow:
Tcl_AppendResult(interp, "bad window name/identifier \"",name,"\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "WINDOW_ID", NULL);
return TCL_ERROR;
}
@@ -3560,6 +3568,7 @@ GetVirtualEventUid(
virtString[length - 2] != '>' || virtString[length - 1] != '>') {
Tcl_AppendResult(interp, "virtual event \"", virtString,
"\" is badly formed", NULL);
+ Tcl_SetErrorCode(interp, "TK", "EVENT", "VIRTUAL", "MALFORMED", NULL);
return NULL;
}
virtString[length - 2] = '\0';
@@ -3654,6 +3663,8 @@ FindSequence(
Tcl_SetResult(interp,
"virtual event not allowed in definition of another virtual event",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "EVENT", "VIRTUAL", "INNER",
+ NULL);
return NULL;
}
virtualFound = 1;
@@ -3680,11 +3691,14 @@ FindSequence(
if (numPats == 0) {
Tcl_SetResult(interp, "no events specified in binding", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "EVENT", "NO_EVENTS", NULL);
return NULL;
}
if ((numPats > 1) && (virtualFound != 0)) {
Tcl_SetResult(interp, "virtual events may not be composed",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "EVENT", "VIRTUAL", "COMPOSITION",
+ NULL);
return NULL;
}
@@ -3804,6 +3818,7 @@ ParseEventDescription(
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad ASCII character 0x%x", UCHAR(*p)));
+ Tcl_SetErrorCode(interp, "TK", "EVENT", "BAD_CHAR", NULL);
count = 0;
goto done;
}
@@ -3846,12 +3861,16 @@ ParseEventDescription(
if (p == field) {
Tcl_SetResult(interp, "virtual event \"<<>>\" is badly formed",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "EVENT", "VIRTUAL", "MALFORMED",
+ NULL);
count = 0;
goto done;
}
if ((p == NULL) || (p[1] != '>')) {
Tcl_SetResult(interp, "missing \">\" in virtual binding",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "EVENT", "VIRTUAL", "MALFORMED",
+ NULL);
count = 0;
goto done;
}
@@ -3920,6 +3939,7 @@ ParseEventDescription(
} else if ((eventFlags & BUTTON) == 0) {
Tcl_AppendResult(interp, "specified button \"", field,
"\" for non-button event", NULL);
+ Tcl_SetErrorCode(interp, "TK", "EVENT", "NON_BUTTON", NULL);
count = 0;
goto done;
}
@@ -3931,6 +3951,7 @@ ParseEventDescription(
if (patPtr->detail.keySym == NoSymbol) {
Tcl_AppendResult(interp, "bad event type or keysym \"",
field, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "KEYSYM", NULL);
count = 0;
goto done;
}
@@ -3940,6 +3961,7 @@ ParseEventDescription(
} else if ((eventFlags & KEY) == 0) {
Tcl_AppendResult(interp, "specified keysym \"", field,
"\" for non-key event", NULL);
+ Tcl_SetErrorCode(interp, "TK", "EVENT", "NON_KEY", NULL);
count = 0;
goto done;
}
@@ -3947,6 +3969,7 @@ ParseEventDescription(
} else if (eventFlags == 0) {
Tcl_SetResult(interp, "no event type or button # or keysym",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "EVENT", "UNMODIFIABLE", NULL);
count = 0;
goto done;
}
@@ -3961,11 +3984,13 @@ ParseEventDescription(
Tcl_SetResult(interp,
"extra characters after detail in binding",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "EVENT", "PAST_DETAIL", NULL);
count = 0;
goto done;
}
}
Tcl_SetResult(interp, "missing \">\" in binding", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "EVENT", "MALFORMED", NULL);
count = 0;
goto done;
}
diff --git a/generic/tkBitmap.c b/generic/tkBitmap.c
index b0d1ecc..5349fd5 100644
--- a/generic/tkBitmap.c
+++ b/generic/tkBitmap.c
@@ -344,6 +344,7 @@ GetBitmap(
if (Tcl_IsSafe(interp)) {
Tcl_AppendResult(interp, "can't specify bitmap with '@' in a",
" safe interpreter", NULL);
+ Tcl_SetErrorCode(interp, "TK", "SAFE", "BITMAP_FILE", NULL);
goto error;
}
@@ -365,6 +366,7 @@ GetBitmap(
if (interp != NULL) {
Tcl_AppendResult(interp, "error reading bitmap file \"",
string, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "BITMAP", "FILE_ERROR", NULL);
}
Tcl_DStringFree(&buffer);
goto error;
@@ -386,6 +388,7 @@ GetBitmap(
if (interp != NULL) {
Tcl_AppendResult(interp, "bitmap \"", string,
"\" not defined", NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "BITMAP", NULL);
}
goto error;
}
@@ -489,6 +492,7 @@ Tk_DefineBitmap(
if (!isNew) {
Tcl_AppendResult(interp, "bitmap \"", name, "\" is already defined",
NULL);
+ Tcl_SetErrorCode(interp, "TK", "BITMAP", "EXISTS", NULL);
return TCL_ERROR;
}
predefPtr = ckalloc(sizeof(TkPredefBitmap));
diff --git a/generic/tkBusy.c b/generic/tkBusy.c
index fc7f6ab..5439969 100644
--- a/generic/tkBusy.c
+++ b/generic/tkBusy.c
@@ -689,6 +689,7 @@ GetBusy(
if (hPtr == NULL) {
Tcl_AppendResult(interp, "can't find busy window \"",
Tcl_GetString(windowObj), "\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "BUSY", NULL);
return NULL;
}
return Tcl_GetHashValue(hPtr);
diff --git a/generic/tkCanvArc.c b/generic/tkCanvArc.c
index 6cbc89b..d8a8062 100644
--- a/generic/tkCanvArc.c
+++ b/generic/tkCanvArc.c
@@ -344,27 +344,21 @@ ArcCoords(
ArcItem *arcPtr = (ArcItem *) itemPtr;
if (objc == 0) {
- Tcl_Obj *obj = Tcl_NewObj();
- Tcl_Obj *subobj = Tcl_NewDoubleObj(arcPtr->bbox[0]);
-
- Tcl_ListObjAppendElement(interp, obj, subobj);
- subobj = Tcl_NewDoubleObj(arcPtr->bbox[1]);
- Tcl_ListObjAppendElement(interp, obj, subobj);
- subobj = Tcl_NewDoubleObj(arcPtr->bbox[2]);
- Tcl_ListObjAppendElement(interp, obj, subobj);
- subobj = Tcl_NewDoubleObj(arcPtr->bbox[3]);
- Tcl_ListObjAppendElement(interp, obj, subobj);
- Tcl_SetObjResult(interp, obj);
+ Tcl_Obj *objs[4];
+
+ objs[0] = Tcl_NewDoubleObj(arcPtr->bbox[0]);
+ objs[1] = Tcl_NewDoubleObj(arcPtr->bbox[1]);
+ objs[2] = Tcl_NewDoubleObj(arcPtr->bbox[2]);
+ objs[3] = Tcl_NewDoubleObj(arcPtr->bbox[3]);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(4, objs));
} else if ((objc == 1)||(objc == 4)) {
if (objc==1) {
if (Tcl_ListObjGetElements(interp, objv[0], &objc,
(Tcl_Obj ***) &objv) != TCL_OK) {
return TCL_ERROR;
} else if (objc != 4) {
- char buf[64 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "wrong # coordinates: expected 4, got %d", objc);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # coordinates: expected 4, got %d", objc));
return TCL_ERROR;
}
}
@@ -380,10 +374,8 @@ ArcCoords(
}
ComputeArcBbox(canvas, arcPtr);
} else {
- char buf[64 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "wrong # coordinates: expected 0 or 4, got %d", objc);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # coordinates: expected 0 or 4, got %d", objc));
return TCL_ERROR;
}
return TCL_OK;
diff --git a/generic/tkCanvBmap.c b/generic/tkCanvBmap.c
index ea16a29..adaa184 100644
--- a/generic/tkCanvBmap.c
+++ b/generic/tkCanvBmap.c
@@ -249,10 +249,8 @@ BitmapCoords(
if (objc == 0) {
Tcl_Obj *obj = Tcl_NewObj();
- Tcl_Obj *subobj = Tcl_NewDoubleObj(bmapPtr->x);
- Tcl_ListObjAppendElement(interp, obj, subobj);
- subobj = Tcl_NewDoubleObj(bmapPtr->y);
- Tcl_ListObjAppendElement(interp, obj, subobj);
+ Tcl_ListObjAppendElement(NULL, obj, Tcl_NewDoubleObj(bmapPtr->x));
+ Tcl_ListObjAppendElement(NULL, obj, Tcl_NewDoubleObj(bmapPtr->y));
Tcl_SetObjResult(interp, obj);
} else if (objc < 3) {
if (objc == 1) {
@@ -260,10 +258,8 @@ BitmapCoords(
(Tcl_Obj ***) &objv) != TCL_OK) {
return TCL_ERROR;
} else if (objc != 2) {
- char buf[64 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "wrong # coordinates: expected 2, got %d", objc);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # coordinates: expected 2, got %d", objc));
return TCL_ERROR;
}
}
@@ -275,10 +271,8 @@ BitmapCoords(
}
ComputeBitmapBbox(canvas, bmapPtr);
} else {
- char buf[64 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "wrong # coordinates: expected 0 or 2, got %d", objc);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # coordinates: expected 0 or 2, got %d", objc));
return TCL_ERROR;
}
return TCL_OK;
diff --git a/generic/tkCanvImg.c b/generic/tkCanvImg.c
index 880070b..b92659b 100644
--- a/generic/tkCanvImg.c
+++ b/generic/tkCanvImg.c
@@ -232,23 +232,19 @@ ImageCoords(
ImageItem *imgPtr = (ImageItem *) itemPtr;
if (objc == 0) {
- Tcl_Obj *obj = Tcl_NewObj();
+ Tcl_Obj *objs[2];
- Tcl_Obj *subobj = Tcl_NewDoubleObj(imgPtr->x);
- Tcl_ListObjAppendElement(interp, obj, subobj);
- subobj = Tcl_NewDoubleObj(imgPtr->y);
- Tcl_ListObjAppendElement(interp, obj, subobj);
- Tcl_SetObjResult(interp, obj);
+ objs[0] = Tcl_NewDoubleObj(imgPtr->x);
+ objs[1] = Tcl_NewDoubleObj(imgPtr->y);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, objs));
} else if (objc < 3) {
if (objc==1) {
if (Tcl_ListObjGetElements(interp, objv[0], &objc,
(Tcl_Obj ***) &objv) != TCL_OK) {
return TCL_ERROR;
} else if (objc != 2) {
- char buf[64];
-
- sprintf(buf, "wrong # coordinates: expected 2, got %d", objc);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # coordinates: expected 2, got %d", objc));
return TCL_ERROR;
}
}
@@ -259,10 +255,8 @@ ImageCoords(
}
ComputeImageBbox(canvas, imgPtr);
} else {
- char buf[64];
-
- sprintf(buf, "wrong # coordinates: expected 0 or 2, got %d", objc);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # coordinates: expected 0 or 2, got %d", objc));
return TCL_ERROR;
}
return TCL_OK;
diff --git a/generic/tkCanvLine.c b/generic/tkCanvLine.c
index 20a391e..e2dd8d3 100644
--- a/generic/tkCanvLine.c
+++ b/generic/tkCanvLine.c
@@ -391,54 +391,50 @@ LineCoords(
}
}
if (objc & 1) {
- char buf[64 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "wrong # coordinates: expected an even number, got %d",
- objc);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # coordinates: expected an even number, got %d",
+ objc));
return TCL_ERROR;
} else if (objc < 4) {
- char buf[64 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "wrong # coordinates: expected at least 4, got %d", objc);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # coordinates: expected at least 4, got %d", objc));
return TCL_ERROR;
- } else {
- numPoints = objc/2;
- if (linePtr->numPoints != numPoints) {
- coordPtr = ckalloc(sizeof(double) * objc);
- if (linePtr->coordPtr != NULL) {
- ckfree(linePtr->coordPtr);
- }
- linePtr->coordPtr = coordPtr;
- linePtr->numPoints = numPoints;
+ }
+
+ numPoints = objc/2;
+ if (linePtr->numPoints != numPoints) {
+ coordPtr = ckalloc(sizeof(double) * objc);
+ if (linePtr->coordPtr != NULL) {
+ ckfree(linePtr->coordPtr);
}
- coordPtr = linePtr->coordPtr;
- for (i = 0; i < objc ; i++) {
- if (Tk_CanvasGetCoordFromObj(interp, canvas, objv[i],
- coordPtr++) != TCL_OK) {
- return TCL_ERROR;
- }
+ linePtr->coordPtr = coordPtr;
+ linePtr->numPoints = numPoints;
+ }
+ coordPtr = linePtr->coordPtr;
+ for (i = 0; i < objc ; i++) {
+ if (Tk_CanvasGetCoordFromObj(interp, canvas, objv[i],
+ coordPtr++) != TCL_OK) {
+ return TCL_ERROR;
}
+ }
- /*
- * Update arrowheads by throwing away any existing arrow-head
- * information and calling ConfigureArrows to recompute it.
- */
+ /*
+ * Update arrowheads by throwing away any existing arrow-head information
+ * and calling ConfigureArrows to recompute it.
+ */
- if (linePtr->firstArrowPtr != NULL) {
- ckfree(linePtr->firstArrowPtr);
- linePtr->firstArrowPtr = NULL;
- }
- if (linePtr->lastArrowPtr != NULL) {
- ckfree(linePtr->lastArrowPtr);
- linePtr->lastArrowPtr = NULL;
- }
- if (linePtr->arrow != ARROWS_NONE) {
- ConfigureArrows(canvas, linePtr);
- }
- ComputeLineBbox(canvas, linePtr);
+ if (linePtr->firstArrowPtr != NULL) {
+ ckfree(linePtr->firstArrowPtr);
+ linePtr->firstArrowPtr = NULL;
+ }
+ if (linePtr->lastArrowPtr != NULL) {
+ ckfree(linePtr->lastArrowPtr);
+ linePtr->lastArrowPtr = NULL;
+ }
+ if (linePtr->arrow != ARROWS_NONE) {
+ ConfigureArrows(canvas, linePtr);
}
+ ComputeLineBbox(canvas, linePtr);
return TCL_OK;
}
@@ -1894,16 +1890,8 @@ ParseArrowShape(
}
if (Tcl_SplitList(interp, (char *) value, &argc, &argv) != TCL_OK) {
- syntaxError:
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad arrow shape \"", value,
- "\": must be list with three numbers", NULL);
- if (argv != NULL) {
- ckfree(argv);
- }
- return TCL_ERROR;
- }
- if (argc != 3) {
+ goto syntaxError;
+ } else if (argc != 3) {
goto syntaxError;
}
if ((Tk_CanvasGetCoord(interp, linePtr->canvas, argv[0], &a) != TCL_OK)
@@ -1913,11 +1901,21 @@ ParseArrowShape(
!= TCL_OK)) {
goto syntaxError;
}
+
linePtr->arrowShapeA = (float) a;
linePtr->arrowShapeB = (float) b;
linePtr->arrowShapeC = (float) c;
ckfree(argv);
return TCL_OK;
+
+ syntaxError:
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "bad arrow shape \"", value,
+ "\": must be list with three numbers", NULL);
+ if (argv != NULL) {
+ ckfree(argv);
+ }
+ return TCL_ERROR;
}
/*
diff --git a/generic/tkCanvPs.c b/generic/tkCanvPs.c
index eafc07f..69c9cfb 100644
--- a/generic/tkCanvPs.c
+++ b/generic/tkCanvPs.c
@@ -548,11 +548,9 @@ TkCanvPostscriptCmd(
result = itemPtr->typePtr->postscriptProc(interp,
(Tk_Canvas) canvasPtr, itemPtr, 0);
if (result != TCL_OK) {
- char msg[64 + TCL_INTEGER_SPACE];
-
- sprintf(msg, "\n (generating Postscript for item %d)",
- itemPtr->id);
- Tcl_AddErrorInfo(interp, msg);
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (generating Postscript for item %d)",
+ itemPtr->id));
goto cleanup;
}
Tcl_AppendResult(interp, "grestore\n", NULL);
diff --git a/generic/tkCanvWind.c b/generic/tkCanvWind.c
index f2cce7d..0c54741 100644
--- a/generic/tkCanvWind.c
+++ b/generic/tkCanvWind.c
@@ -246,22 +246,19 @@ WinItemCoords(
WindowItem *winItemPtr = (WindowItem *) itemPtr;
if (objc == 0) {
- Tcl_Obj *obj = Tcl_NewObj();
- Tcl_Obj *subobj = Tcl_NewDoubleObj(winItemPtr->x);
- Tcl_ListObjAppendElement(interp, obj, subobj);
- subobj = Tcl_NewDoubleObj(winItemPtr->y);
- Tcl_ListObjAppendElement(interp, obj, subobj);
- Tcl_SetObjResult(interp, obj);
+ Tcl_Obj *objs[2];
+
+ objs[0] = Tcl_NewDoubleObj(winItemPtr->x);
+ objs[1] = Tcl_NewDoubleObj(winItemPtr->y);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, objs));
} else if (objc < 3) {
if (objc==1) {
if (Tcl_ListObjGetElements(interp, objv[0], &objc,
(Tcl_Obj ***) &objv) != TCL_OK) {
return TCL_ERROR;
} else if (objc != 2) {
- char buf[64 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "wrong # coordinates: expected 2, got %d", objc);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # coordinates: expected 2, got %d", objc));
return TCL_ERROR;
}
}
@@ -272,10 +269,8 @@ WinItemCoords(
}
ComputeWindowBbox(canvas, winItemPtr);
} else {
- char buf[64 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "wrong # coordinates: expected 0 or 2, got %d", objc);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # coordinates: expected 0 or 2, got %d", objc));
return TCL_ERROR;
}
return TCL_OK;
diff --git a/generic/tkColor.c b/generic/tkColor.c
index 9383a92..b1ed4f1 100644
--- a/generic/tkColor.c
+++ b/generic/tkColor.c
@@ -226,9 +226,11 @@ Tk_GetColor(
if (*name == '#') {
Tcl_AppendResult(interp, "invalid color name \"", name,
"\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "COLOR", NULL);
} else {
Tcl_AppendResult(interp, "unknown color name \"", name,
"\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "COLOR", name, NULL);
}
}
if (isNew) {
@@ -372,10 +374,12 @@ Tk_NameOfColor(
sprintf(tsdPtr->rgbString, "#%04x%04x%04x", colorPtr->red,
colorPtr->green, colorPtr->blue);
- /* If the string has the form #RSRSTUTUVWVW (where equal
- * letters denote equal hexdigits) then this is
- * equivalent to #RSTUVW. Then output the shorter form.
+ /*
+ * If the string has the form #RSRSTUTUVWVW (where equal letters
+ * denote equal hexdigits) then this is equivalent to #RSTUVW. Then
+ * output the shorter form.
*/
+
if ((tsdPtr->rgbString[1] == tsdPtr->rgbString[3])
&& (tsdPtr->rgbString[2] == tsdPtr->rgbString[4])
&& (tsdPtr->rgbString[5] == tsdPtr->rgbString[7])
diff --git a/generic/tkConfig.c b/generic/tkConfig.c
index 5262f58..51ac6dc 100644
--- a/generic/tkConfig.c
+++ b/generic/tkConfig.c
@@ -946,16 +946,13 @@ DoObjConfig(
break;
}
- {
- char buf[40+TCL_INTEGER_SPACE];
-
default:
- sprintf(buf, "bad config table: unknown type %d",
- optionPtr->specPtr->type);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad config table: unknown type %d",
+ optionPtr->specPtr->type));
+ Tcl_SetErrorCode(interp, "TK", "BAD_CONFIG", NULL);
return TCL_ERROR;
}
- }
/*
* Release resources associated with the old value, if we're not returning
@@ -1162,6 +1159,7 @@ GetOptionFromObj(
error:
if (interp != NULL) {
Tcl_AppendResult(interp, "unknown option \"", name, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "OPTION", name, NULL);
}
return NULL;
}
@@ -1231,9 +1229,10 @@ SetOptionFromAny(
Tcl_AppendResult(interp,
"can't convert value to option except via GetOptionFromObj API",
NULL);
+ Tcl_SetErrorCode(interp, "TK", "API_ABUSE", NULL);
return TCL_ERROR;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1348,6 +1347,7 @@ Tk_SetOptions(
if (interp != NULL) {
Tcl_AppendResult(interp, "value for \"",
Tcl_GetStringFromObj(*objv, NULL), "\" missing",NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE_MISSING", NULL);
goto error;
}
}
@@ -1369,11 +1369,9 @@ Tk_SetOptions(
if (DoObjConfig(interp, recordPtr, optionPtr, objv[1], tkwin,
(savePtr != NULL) ? &lastSavePtr->items[lastSavePtr->numItems]
: NULL) != TCL_OK) {
- char msg[100];
-
- sprintf(msg, "\n (processing \"%.40s\" option)",
- Tcl_GetStringFromObj(*objv, NULL));
- Tcl_AddErrorInfo(interp, msg);
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (processing \"%.40s\" option)",
+ Tcl_GetStringFromObj(*objv, NULL)));
goto error;
}
if (savePtr != NULL) {
@@ -1771,7 +1769,6 @@ FreeResources(
* single option or all the configuration options in a table.
*
* Results:
-
* This function normally returns a pointer to an object. If namePtr
* isn't NULL, then the result object is a list with five elements: the
* option's name, its database name, database class, default value, and
@@ -2154,8 +2151,7 @@ TkDebugConfig(
Tcl_Obj *objPtr;
objPtr = Tcl_NewObj();
- hashTablePtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, OPTION_HASH_KEY,
- NULL);
+ hashTablePtr = Tcl_GetAssocData(interp, OPTION_HASH_KEY, NULL);
if (hashTablePtr == NULL) {
return objPtr;
}
diff --git a/generic/tkEntry.c b/generic/tkEntry.c
index 044a35b..39aa228 100644
--- a/generic/tkEntry.c
+++ b/generic/tkEntry.c
@@ -2935,10 +2935,9 @@ EntryUpdateScrollbar(
code = Tcl_VarEval(interp, entryPtr->scrollCmd, " ", firstStr, " ",
lastStr, NULL);
if (code != TCL_OK) {
- Tcl_AddErrorInfo(interp,
- "\n (horizontal scrolling command executed by ");
- Tcl_AddErrorInfo(interp, Tk_PathName(entryPtr->tkwin));
- Tcl_AddErrorInfo(interp, ")");
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (horizontal scrolling command executed by %s)",
+ Tk_PathName(entryPtr->tkwin)));
Tcl_BackgroundException(interp, code);
}
Tcl_ResetResult(interp);
@@ -3141,7 +3140,7 @@ EntryValidate(
if (code != TCL_OK && code != TCL_RETURN) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n\t(in validation command executed by %s)",
+ "\n (in validation command executed by %s)",
Tk_PathName(entryPtr->tkwin)));
Tcl_BackgroundException(interp, code);
return TCL_ERROR;
@@ -3154,7 +3153,7 @@ EntryValidate(
if (Tcl_GetBooleanFromObj(interp, Tcl_GetObjResult(interp),
&bool) != TCL_OK) {
Tcl_AddErrorInfo(interp,
- "\nvalid boolean not returned by validation command");
+ "\n (invalid boolean result from validation command)");
Tcl_BackgroundError(interp);
Tcl_ResetResult(interp);
return TCL_ERROR;
@@ -3280,7 +3279,7 @@ EntryValidateChange(
TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
if (result != TCL_OK) {
Tcl_AddErrorInfo(entryPtr->interp,
- "\n\t(in invalidcommand executed by entry)");
+ "\n (in invalidcommand executed by entry)");
Tcl_BackgroundException(entryPtr->interp, result);
code = TCL_ERROR;
entryPtr->validate = VALIDATE_NONE;
@@ -4284,7 +4283,8 @@ SpinboxInvoke(
Tcl_DStringFree(&script);
if (code != TCL_OK) {
- Tcl_AddErrorInfo(interp, "\n\t(in command executed by spinbox)");
+ Tcl_AddErrorInfo(interp,
+ "\n (in command executed by spinbox)");
Tcl_BackgroundException(interp, code);
/*
diff --git a/generic/tkFont.c b/generic/tkFont.c
index 32d0589..e536c41 100644
--- a/generic/tkFont.c
+++ b/generic/tkFont.c
@@ -569,6 +569,7 @@ Tk_FontObjCmd(
-1, 40, "...");
Tcl_AppendToObj(resultPtr, "\"", -1);
Tcl_SetObjResult(interp, resultPtr);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "FONT_SAMPLE", NULL);
return TCL_ERROR;
}
uniChar = Tcl_GetUniChar(charPtr, 0);
@@ -618,6 +619,7 @@ Tk_FontObjCmd(
if ((namedHashPtr == NULL) || (nfPtr->deletePending != 0)) {
Tcl_AppendResult(interp, "named font \"", string,
"\" doesn't exist", NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "FONT", string, NULL);
return TCL_ERROR;
}
if (objc == 3) {
@@ -951,6 +953,7 @@ TkCreateNamedFont(
if (interp) {
Tcl_AppendResult(interp, "named font \"", name,
"\" already exists", NULL);
+ Tcl_SetErrorCode(interp, "TK", "FONT", "EXISTS", NULL);
}
return TCL_ERROR;
}
@@ -1002,6 +1005,7 @@ TkDeleteNamedFont(
if (interp) {
Tcl_AppendResult(interp, "named font \"", name,
"\" doesn't exist", NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "FONT", name, NULL);
}
return TCL_ERROR;
}
@@ -1185,6 +1189,7 @@ Tk_AllocFontFromObj(
}
Tcl_AppendResult(interp, "failed to allocate font due to ",
"internal system font engine problem", NULL);
+ Tcl_SetErrorCode(interp, "TK", "FONT", "INTERNAL_PROBLEM", NULL);
return NULL;
}
@@ -3405,6 +3410,7 @@ ConfigAttributesObj(
if (interp != NULL) {
Tcl_AppendResult(interp, "value for \"",
Tcl_GetString(optionPtr), "\" option missing", NULL);
+ Tcl_SetErrorCode(interp, "TK", "FONT", "NO_ATTRIBUTE", NULL);
}
return TCL_ERROR;
}
@@ -3648,6 +3654,7 @@ ParseFontNameObj(
if (interp != NULL) {
Tcl_AppendResult(interp, "font \"", string, "\" doesn't exist",
NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "FONT", string, NULL);
}
return TCL_ERROR;
}
@@ -3696,6 +3703,8 @@ ParseFontNameObj(
if (interp != NULL) {
Tcl_AppendResult(interp, "unknown font style \"",
Tcl_GetString(objv[i]), "\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "FONT_STYLE",
+ Tcl_GetString(objv[i]), NULL);
}
return TCL_ERROR;
}
@@ -4077,7 +4086,6 @@ TkFontGetPoints(
* platform expects when asking for the font.
*
* Results:
-
* As above. The return value is NULL if the font name has no aliases.
*
* Side effects:
diff --git a/generic/tkGrab.c b/generic/tkGrab.c
index 695690b..9e9daae 100644
--- a/generic/tkGrab.c
+++ b/generic/tkGrab.c
@@ -215,6 +215,7 @@ Tk_GrabObjCmd(
Tcl_AppendResult(interp, "wrong # args: should be \"",
Tcl_GetString(objv[0]), " ?-global? window\" or \"",
Tcl_GetString(objv[0]), " option ?arg ...?\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
@@ -410,10 +411,7 @@ Tk_Grab(
return TCL_OK;
}
if (dispPtr->eventualGrabWinPtr->mainPtr != winPtr->mainPtr) {
- alreadyGrabbed:
- Tcl_SetResult(interp, "grab failed: another application has grab",
- TCL_STATIC);
- return TCL_ERROR;
+ goto alreadyGrabbed;
}
Tk_Ungrab((Tk_Window) dispPtr->eventualGrabWinPtr);
}
@@ -423,7 +421,7 @@ Tk_Grab(
if (!grabGlobal)
#else
if (0)
-#endif
+#endif /* MAC_OSX_TK */
{
Window dummy1, dummy2;
int dummy3, dummy4, dummy5, dummy6;
@@ -479,26 +477,7 @@ Tk_Grab(
Tcl_Sleep(100);
}
if (grabResult != 0) {
- grabError:
- if (grabResult == GrabNotViewable) {
- Tcl_SetResult(interp, "grab failed: window not viewable",
- TCL_STATIC);
- } else if (grabResult == AlreadyGrabbed) {
- goto alreadyGrabbed;
- } else if (grabResult == GrabFrozen) {
- Tcl_SetResult(interp,
- "grab failed: keyboard or pointer frozen", TCL_STATIC);
- } else if (grabResult == GrabInvalidTime) {
- Tcl_SetResult(interp, "grab failed: invalid time",
- TCL_STATIC);
- } else {
- char msg[64 + TCL_INTEGER_SPACE];
-
- sprintf(msg, "grab failed for unknown reason (code %d)",
- grabResult);
- Tcl_AppendResult(interp, msg, NULL);
- }
- return TCL_ERROR;
+ goto grabError;
}
grabResult = XGrabKeyboard(dispPtr->display, Tk_WindowId(tkwin),
False, GrabModeAsync, GrabModeAsync, CurrentTime);
@@ -546,6 +525,29 @@ Tk_Grab(
}
QueueGrabWindowChange(dispPtr, winPtr);
return TCL_OK;
+
+ grabError:
+ if (grabResult == GrabNotViewable) {
+ Tcl_SetResult(interp, "grab failed: window not viewable", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "GRAB", "UNVIEWABLE", NULL);
+ } else if (grabResult == AlreadyGrabbed) {
+ alreadyGrabbed:
+ Tcl_SetResult(interp, "grab failed: another application has grab",
+ TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "GRAB", "GRABBED", NULL);
+ } else if (grabResult == GrabFrozen) {
+ Tcl_SetResult(interp,
+ "grab failed: keyboard or pointer frozen", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "GRAB", "FROZEN", NULL);
+ } else if (grabResult == GrabInvalidTime) {
+ Tcl_SetResult(interp, "grab failed: invalid time", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "GRAB", "BADTIME", NULL);
+ } else {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "grab failed for unknown reason (code %d)", grabResult));
+ Tcl_SetErrorCode(interp, "TK", "GRAB", "UNKNOWN", NULL);
+ }
+ return TCL_ERROR;
}
/*
diff --git a/generic/tkGrid.c b/generic/tkGrid.c
index 70d463e..627bb89 100644
--- a/generic/tkGrid.c
+++ b/generic/tkGrid.c
@@ -402,7 +402,7 @@ Tk_GridObjCmd(
}
/* This should not happen */
- Tcl_SetResult(interp, "Internal error in grid.", TCL_STATIC);
+ Tcl_SetResult(interp, "internal error in grid", TCL_STATIC);
return TCL_ERROR;
}
@@ -997,6 +997,7 @@ GridRowColumnConfigureCommand(
Tcl_AppendResult(interp, "no ",
(slotType == COLUMN) ? "column" : "row",
" indices specified", NULL);
+ Tcl_SetErrorCode(interp, "TK", "GRID", "NOINDEX", NULL);
Tcl_DecrRefCount(listCopy);
return TCL_ERROR;
}
@@ -1010,6 +1011,7 @@ GridRowColumnConfigureCommand(
Tcl_AppendResult(interp, Tcl_GetString(objv[0]), " ",
Tcl_GetString(objv[1]),
": must specify a single element on retrieval", NULL);
+ Tcl_SetErrorCode(interp, "TK", "GRID", "USAGE", NULL);
Tcl_DecrRefCount(listCopy);
return TCL_ERROR;
}
@@ -1017,6 +1019,7 @@ GridRowColumnConfigureCommand(
Tcl_AppendResult(interp,
" (when retreiving options only integer indices are "
"allowed)", NULL);
+ Tcl_SetErrorCode(interp, "TK", "GRID", "INDEX_FORMAT", NULL);
Tcl_DecrRefCount(listCopy);
return TCL_ERROR;
}
@@ -1122,6 +1125,7 @@ GridRowColumnConfigureCommand(
Tcl_GetString(objv[1]), ": the window \"",
Tcl_GetString(lObjv[j]), "\" is not managed by \"",
Tcl_GetString(objv[2]), "\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "GRID_MASTER", NULL);
Tcl_DecrRefCount(listCopy);
return TCL_ERROR;
}
@@ -1129,6 +1133,7 @@ GridRowColumnConfigureCommand(
Tcl_AppendResult(interp, Tcl_GetString(objv[0]), " ",
Tcl_GetString(objv[1]), ": illegal index \"",
Tcl_GetString(lObjv[j]), "\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID_INDEX", NULL);
Tcl_DecrRefCount(listCopy);
return TCL_ERROR;
}
@@ -1152,6 +1157,7 @@ GridRowColumnConfigureCommand(
Tcl_GetString(objv[1]), ": \"",
Tcl_GetString(lObjv[j]),
"\" is out of range", NULL);
+ Tcl_SetErrorCode(interp, "TK", "GRID", "INDEX_RANGE", NULL);
Tcl_DecrRefCount(listCopy);
return TCL_ERROR;
}
@@ -1189,6 +1195,8 @@ GridRowColumnConfigureCommand(
Tcl_GetString(objv[i]),
"\": should be non-negative", NULL);
Tcl_DecrRefCount(listCopy);
+ Tcl_SetErrorCode(interp, "TK", "GRID",
+ "NEG_INDEX", NULL);
return TCL_ERROR;
} else {
slotPtr[slot].weight = wt;
@@ -1209,6 +1217,8 @@ GridRowColumnConfigureCommand(
Tcl_AppendResult(interp, "invalid arg \"",
Tcl_GetString(objv[i]),
"\": should be non-negative", NULL);
+ Tcl_SetErrorCode(interp, "TK", "GRID",
+ "NEG_INDEX", NULL);
Tcl_DecrRefCount(listCopy);
return TCL_ERROR;
} else {
@@ -1363,6 +1373,7 @@ GridSlavesCommand(
if (value < 0) {
Tcl_AppendResult(interp, Tcl_GetString(objv[i]),
" is an invalid value: should NOT be < 0", NULL);
+ Tcl_SetErrorCode(interp, "TK", "GRID", "NEG_INDEX", NULL);
return TCL_ERROR;
}
if (index == SLAVES_COLUMN) {
@@ -2529,6 +2540,7 @@ SetSlaveColumn(
lastCol = ((newColumn >= 0) ? newColumn : 0) + newNumCols;
if (lastCol >= MAX_ELEMENT) {
Tcl_SetResult(interp, "Column out of bounds", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "GRID", "BAD_COLUMN", NULL);
return TCL_ERROR;
}
@@ -2569,6 +2581,7 @@ SetSlaveRow(
lastRow = ((newRow >= 0) ? newRow : 0) + newNumRows;
if (lastRow >= MAX_ELEMENT) {
Tcl_SetResult(interp, "Row out of bounds", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "GRID", "BAD_ROW", NULL);
return TCL_ERROR;
}
@@ -2994,6 +3007,7 @@ ConfigureSlaves(
if (length > 1 && i == 0) {
Tcl_AppendResult(interp, "bad argument \"", string,
"\": must be name of window", NULL);
+ Tcl_SetErrorCode(interp, "TK", "GRID", "BAD_PARAMETER", NULL);
return TCL_ERROR;
}
if (length > 1 && firstChar == '-') {
@@ -3003,6 +3017,7 @@ ConfigureSlaves(
Tcl_AppendResult(interp, "unexpected parameter, \"",
string, "\", in configure list. ",
"Should be window name or option", NULL);
+ Tcl_SetErrorCode(interp, "TK", "GRID", "BAD_PARAMETER", NULL);
return TCL_ERROR;
}
@@ -3010,6 +3025,7 @@ ConfigureSlaves(
(prevChar == REL_SKIP) || (prevChar == REL_VERT))) {
Tcl_AppendResult(interp,
"Must specify window before shortcut '-'.", NULL);
+ Tcl_SetErrorCode(interp, "TK", "GRID", "SHORTCUT_USAGE", NULL);
return TCL_ERROR;
}
@@ -3020,12 +3036,14 @@ ConfigureSlaves(
Tcl_AppendResult(interp, "invalid window shortcut, \"",
string, "\" should be '-', 'x', or '^'", NULL);
+ Tcl_SetErrorCode(interp, "TK", "GRID", "SHORTCUT_USAGE", NULL);
return TCL_ERROR;
}
numWindows = i;
if ((objc - numWindows) & 1) {
Tcl_AppendResult(interp, "extra option or option with no value", NULL);
+ Tcl_SetErrorCode(interp, "TK", "GRID", "BAD_PARAMETER", NULL);
return TCL_ERROR;
}
@@ -3055,6 +3073,7 @@ ConfigureSlaves(
Tcl_AppendResult(interp, "bad row value \"",
Tcl_GetString(objv[i+1]), "\": must be ",
"a non-negative integer", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "POSITIVE_INT", NULL);
return TCL_ERROR;
}
defaultRow = tmp;
@@ -3118,6 +3137,7 @@ ConfigureSlaves(
if (Tk_TopWinHierarchy(slave)) {
Tcl_AppendResult(interp, "can't manage \"", Tcl_GetString(objv[j]),
"\": it's a top-level window", NULL);
+ Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "TOPLEVEL", NULL);
return TCL_ERROR;
}
slavePtr = GetGrid(slave);
@@ -3147,6 +3167,7 @@ ConfigureSlaves(
Tcl_AppendResult(interp, "bad column value \"",
Tcl_GetString(objv[i+1]), "\": must be ",
"a non-negative integer", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "COLUMN", NULL);
return TCL_ERROR;
}
if (SetSlaveColumn(interp, slavePtr, tmp, -1) != TCL_OK) {
@@ -3159,6 +3180,7 @@ ConfigureSlaves(
Tcl_AppendResult(interp, "bad columnspan value \"",
Tcl_GetString(objv[i+1]), "\": must be ",
"a positive integer", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "SPAN", NULL);
return TCL_ERROR;
}
if (SetSlaveColumn(interp, slavePtr, -1, tmp) != TCL_OK) {
@@ -3173,6 +3195,7 @@ ConfigureSlaves(
if (other == slave) {
Tcl_SetResult(interp, "Window can't be managed in itself",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "SELF", NULL);
return TCL_ERROR;
}
positionGiven = 1;
@@ -3186,6 +3209,7 @@ ConfigureSlaves(
Tcl_AppendResult(interp, "bad stickyness value \"",
Tcl_GetString(objv[i+1]), "\": must be ",
"a string containing n, e, s, and/or w", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "STICKY", NULL);
return TCL_ERROR;
}
slavePtr->sticky = sticky;
@@ -3197,6 +3221,7 @@ ConfigureSlaves(
Tcl_AppendResult(interp, "bad ipadx value \"",
Tcl_GetString(objv[i+1]), "\": must be ",
"positive screen distance", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "INT_PAD", NULL);
return TCL_ERROR;
}
slavePtr->iPadX = tmp * 2;
@@ -3207,6 +3232,7 @@ ConfigureSlaves(
Tcl_AppendResult(interp, "bad ipady value \"",
Tcl_GetString(objv[i+1]), "\": must be ",
"positive screen distance", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "INT_PAD", NULL);
return TCL_ERROR;
}
slavePtr->iPadY = tmp * 2;
@@ -3229,6 +3255,7 @@ ConfigureSlaves(
Tcl_AppendResult(interp, "bad row value \"",
Tcl_GetString(objv[i+1]),
"\": must be a non-negative integer", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "COLUMN", NULL);
return TCL_ERROR;
}
if (SetSlaveRow(interp, slavePtr, tmp, -1) != TCL_OK) {
@@ -3241,6 +3268,7 @@ ConfigureSlaves(
Tcl_AppendResult(interp, "bad rowspan value \"",
Tcl_GetString(objv[i+1]),
"\": must be a positive integer", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "SPAN", NULL);
return TCL_ERROR;
}
if (SetSlaveRow(interp, slavePtr, -1, tmp) != TCL_OK) {
@@ -3307,6 +3335,7 @@ ConfigureSlaves(
if (Tk_TopWinHierarchy(ancestor)) {
Tcl_AppendResult(interp, "can't put ", Tcl_GetString(objv[j]),
" inside ", Tk_PathName(masterPtr->tkwin), NULL);
+ Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "HIERARCHY", NULL);
Unlink(slavePtr);
return TCL_ERROR;
}
@@ -3320,6 +3349,7 @@ ConfigureSlaves(
Tcl_AppendResult(interp, "can't put ", Tcl_GetString(objv[j]),
" inside ", Tk_PathName(masterPtr->tkwin),
", would cause management loop.", NULL);
+ Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "LOOP", NULL);
Unlink(slavePtr);
return TCL_ERROR;
}
@@ -3398,6 +3428,7 @@ ConfigureSlaves(
if (masterPtr == NULL) {
Tcl_AppendResult(interp, "can't use '^', cant find master", NULL);
+ Tcl_SetErrorCode(interp, "TK", "GRID", "SHORTCUT_USAGE", NULL);
return TCL_ERROR;
}
@@ -3451,12 +3482,14 @@ ConfigureSlaves(
if (!match) {
Tcl_AppendResult(interp, "can't find slave to extend with \"^\".",
NULL);
+ Tcl_SetErrorCode(interp, "TK", "GRID", "SHORTCUT_USAGE", NULL);
return TCL_ERROR;
}
}
if (masterPtr == NULL) {
Tcl_AppendResult(interp, "can't determine master window", NULL);
+ Tcl_SetErrorCode(interp, "TK", "GRID", "SHORTCUT_USAGE", NULL);
return TCL_ERROR;
}
SetGridSize(masterPtr);
@@ -3497,6 +3530,7 @@ StickyToString(
char *result) /* Where to put the result. */
{
int count = 0;
+
if (flags&STICK_NORTH) {
result[count++] = 'n';
}
diff --git a/generic/tkImage.c b/generic/tkImage.c
index 5fa3671..9cc8738 100644
--- a/generic/tkImage.c
+++ b/generic/tkImage.c
@@ -273,6 +273,7 @@ Tk_ImageObjCmd(
if (typePtr == NULL) {
Tcl_AppendResult(interp, "image type \"", arg, "\" doesn't exist",
NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "IMAGE_TYPE", NULL);
return TCL_ERROR;
}
@@ -306,6 +307,7 @@ Tk_ImageObjCmd(
if (topWin != NULL && winPtr->mainPtr->winPtr == topWin) {
Tcl_AppendResult(interp, "images may not be named the ",
"same as the main window", NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "SMASH_MAIN", NULL);
return TCL_ERROR;
}
}
@@ -491,6 +493,7 @@ Tk_ImageObjCmd(
alreadyDeleted:
Tcl_AppendResult(interp, "image \"", arg, "\" doesn't exist", NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "IMAGE", NULL);
return TCL_ERROR;
}
@@ -631,6 +634,7 @@ Tk_GetImage(
noSuchImage:
if (interp) {
Tcl_AppendResult(interp, "image \"", name, "\" doesn't exist", NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "IMAGE", NULL);
}
return NULL;
}
diff --git a/generic/tkImgBmap.c b/generic/tkImgBmap.c
index 82374cb..a08bb8f 100644
--- a/generic/tkImgBmap.c
+++ b/generic/tkImgBmap.c
@@ -279,6 +279,8 @@ ImgBmapConfigureMaster(
if (masterPtr->data == NULL) {
Tcl_SetResult(masterPtr->interp, "can't have mask without bitmap",
TCL_STATIC);
+ Tcl_SetErrorCode(masterPtr->interp, "TK", "IMAGE", "BITMAP",
+ "NO_BITMAP", NULL);
return TCL_ERROR;
}
masterPtr->maskData = TkGetBitmapData(masterPtr->interp,
@@ -293,6 +295,8 @@ ImgBmapConfigureMaster(
masterPtr->maskData = NULL;
Tcl_SetResult(masterPtr->interp,
"bitmap and mask have different sizes", TCL_STATIC);
+ Tcl_SetErrorCode(masterPtr->interp, "TK", "IMAGE", "BITMAP",
+ "MASK_SIZE", NULL);
return TCL_ERROR;
}
}
@@ -492,6 +496,7 @@ TkGetBitmapData(
if ((interp != NULL) && Tcl_IsSafe(interp)) {
Tcl_AppendResult(interp, "can't get bitmap data from a file in a",
" safe interpreter", NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "BITMAP", "SAFE", NULL);
return NULL;
}
expandedFileName = Tcl_TranslateFileName(interp, fileName, &buffer);
@@ -595,6 +600,8 @@ TkGetBitmapData(
if (interp != NULL) {
Tcl_AppendResult(interp, "format error in bitmap data; ",
"looks like it's an obsolete X10 bitmap file", NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "BITMAP", "OBSOLETE",
+ NULL);
}
goto errorCleanup;
}
@@ -637,6 +644,7 @@ TkGetBitmapData(
error:
if (interp != NULL) {
Tcl_SetResult(interp, "format error in bitmap data", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "BITMAP", "FORMAT", NULL);
}
errorCleanup:
@@ -1154,6 +1162,7 @@ ImgBmapPsImagemask(
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "unable to generate postscript for bitmaps "
"larger than 60000 pixels", NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "BITMAP", "OUTSIZE", NULL);
return TCL_ERROR;
}
diff --git a/generic/tkImgGIF.c b/generic/tkImgGIF.c
index 4cbf94d..62d364f 100644
--- a/generic/tkImgGIF.c
+++ b/generic/tkImgGIF.c
@@ -432,6 +432,8 @@ FileReadGIF(
if (i == (argc-1)) {
Tcl_AppendResult(interp, "no value given for \"",
Tcl_GetString(objv[i]), "\" option", NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "GIF", "OPT_VALUE",
+ NULL);
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[++i], &index) != TCL_OK) {
@@ -446,11 +448,13 @@ FileReadGIF(
if (!ReadGIFHeader(gifConfPtr, chan, &fileWidth, &fileHeight)) {
Tcl_AppendResult(interp, "couldn't read GIF header from file \"",
fileName, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "GIF", "HEADER", NULL);
return TCL_ERROR;
}
if ((fileWidth <= 0) || (fileHeight <= 0)) {
Tcl_AppendResult(interp, "GIF image file \"", fileName,
"\" has dimension(s) <= 0", NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "GIF", "BOGUS_SIZE", NULL);
return TCL_ERROR;
}
@@ -466,6 +470,8 @@ FileReadGIF(
if (BitSet(buf[0], LOCALCOLORMAP)) { /* Global Colormap */
if (!ReadColorMap(gifConfPtr, chan, bitPixel, colorMap)) {
Tcl_AppendResult(interp, "error reading color map", NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "GIF", "COLOR_MAP",
+ NULL);
return TCL_ERROR;
}
}
@@ -503,12 +509,15 @@ FileReadGIF(
Tcl_AppendResult(interp,
"premature end of image data for this index", NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "GIF", "PREMATURE_END",
+ NULL);
goto error;
}
switch (buf[0]) {
case GIF_TERMINATOR:
Tcl_AppendResult(interp, "no image data for this index", NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "GIF", "NO_DATA", NULL);
goto error;
case GIF_EXTENSION:
@@ -520,12 +529,16 @@ FileReadGIF(
Tcl_SetResult(interp,
"error reading extension function code in GIF image",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "GIF", "BAD_EXT",
+ NULL);
goto error;
}
if (DoExtension(gifConfPtr, chan, buf[0],
gifConfPtr->workingBuffer, &transparent) < 0) {
Tcl_SetResult(interp, "error reading extension in GIF image",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "GIF", "BAD_EXT",
+ NULL);
goto error;
}
continue;
@@ -534,6 +547,8 @@ FileReadGIF(
Tcl_SetResult(interp,
"couldn't read left/top/width/height in GIF image",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "GIF", "DIMENSIONS",
+ NULL);
goto error;
}
break;
@@ -562,6 +577,8 @@ FileReadGIF(
if (BitSet(buf[8], LOCALCOLORMAP)) {
if (!ReadColorMap(gifConfPtr, chan, bitPixel, colorMap)) {
Tcl_AppendResult(interp, "error reading color map", NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "GIF",
+ "COLOR_MAP", NULL);
goto error;
}
}
@@ -609,6 +626,7 @@ FileReadGIF(
if (BitSet(buf[8], LOCALCOLORMAP)) {
if (!ReadColorMap(gifConfPtr, chan, bitPixel, colorMap)) {
Tcl_AppendResult(interp, "error reading color map", NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "GIF", "COLOR_MAP", NULL);
goto error;
}
}
@@ -1018,6 +1036,7 @@ ReadImage(
if (initialCodeSize > MAX_LWZ_BITS) {
Tcl_SetResult(interp, "malformed image", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "GIF", "MALFORMED", NULL);
return TCL_ERROR;
}
@@ -1690,6 +1709,7 @@ CommonWriteGIF(
SaveMap(&state, blockPtr);
if (state.num >= MAXCOLORMAPSIZE) {
Tcl_AppendResult(interp, "too many colors", NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "GIF", "COLORFUL", NULL);
return TCL_ERROR;
}
if (state.num<2) {
diff --git a/generic/tkImgPNG.c b/generic/tkImgPNG.c
index 8d6721e..96a17bd 100644
--- a/generic/tkImgPNG.c
+++ b/generic/tkImgPNG.c
@@ -335,6 +335,7 @@ InitPNGImage(
if (Tcl_ZlibStreamInit(NULL, dir, TCL_ZLIB_FORMAT_ZLIB,
TCL_ZLIB_COMPRESS_DEFAULT, NULL, &pngPtr->stream) != TCL_OK) {
Tcl_SetResult(interp, "zlib initialization failed", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "ZLIB_INIT", NULL);
if (objPtr) {
Tcl_DecrRefCount(objPtr);
}
@@ -516,6 +517,7 @@ ReadBase64(
if (destSz) {
Tcl_SetResult(interp, "Unexpected end of image data", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "EARLY_END", NULL);
return TCL_ERROR;
}
@@ -558,6 +560,7 @@ ReadByteArray(
if (pngPtr->strDataLen < destSz) {
Tcl_SetResult(interp, "Unexpected end of image data", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "EARLY_END", NULL);
return TCL_ERROR;
}
@@ -625,7 +628,8 @@ ReadData(
if (blockSz < 0) {
/* TODO: failure info... */
- Tcl_SetResult(interp, "Channel read failed", TCL_STATIC);
+ Tcl_AppendResult(interp, "channel read failed: ",
+ Tcl_PosixError(interp), NULL);
return TCL_ERROR;
}
@@ -647,7 +651,8 @@ ReadData(
*/
if (destSz && Tcl_Eof(pngPtr->channel)) {
- Tcl_SetResult(interp, "Unexpected end of file ", TCL_STATIC);
+ Tcl_SetResult(interp, "unexpected end of file", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "EOF", NULL);
return TCL_ERROR;
}
}
@@ -733,6 +738,7 @@ CheckCRC(
if (calculated != chunked) {
Tcl_SetResult(interp, "CRC check failed", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "CRC", NULL);
return TCL_ERROR;
}
@@ -882,8 +888,9 @@ ReadChunkHeader(
temp = PNG_INT32(pc[0], pc[1], pc[2], pc[3]);
if (temp > INT_MAX) {
- Tcl_SetResult(interp, "Chunk size is out of supported range "
+ Tcl_SetResult(interp, "chunk size is out of supported range "
"on this architecture", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "OUTSIZE", NULL);
return TCL_ERROR;
}
@@ -968,8 +975,10 @@ ReadChunkHeader(
if (!(chunkType & PNG_CF_ANCILLARY)) {
Tcl_SetResult(interp,
- "Encountered an unsupported criticial chunk type",
+ "encountered an unsupported criticial chunk type",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG",
+ "UNSUPPORTED_CRITICAL", NULL);
return TCL_ERROR;
}
@@ -980,7 +989,9 @@ ReadChunkHeader(
for (i=0 ; i<4 ; i++) {
if ((pc[i] < 65) || (pc[i] > 122) ||
((pc[i] > 90) && (pc[i] < 97))) {
- Tcl_SetResult(interp, "Invalid chunk type", TCL_STATIC);
+ Tcl_SetResult(interp, "invalid chunk type", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG",
+ "INVALID_CHUNK", NULL);
return TCL_ERROR;
}
}
@@ -1083,13 +1094,15 @@ CheckColor(
break;
default:
- Tcl_SetResult(interp, "Unknown Color Type field", TCL_STATIC);
+ Tcl_SetResult(interp, "unknown color type field", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "UNKNOWN_COLOR", NULL);
return TCL_ERROR;
}
if (TCL_ERROR == result) {
- Tcl_SetResult(interp, "Bit depth is not allowed for given color type",
+ Tcl_SetResult(interp, "bit depth is not allowed for given color type",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_DEPTH", NULL);
return TCL_ERROR;
}
@@ -1118,8 +1131,9 @@ CheckColor(
if (pngPtr->block.width > INT_MAX / pngPtr->block.pixelSize) {
Tcl_SetResult(interp,
- "Image pitch is out of supported range on this architecture",
+ "image pitch is out of supported range on this architecture",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "PITCH", NULL);
return TCL_ERROR;
}
@@ -1131,8 +1145,9 @@ CheckColor(
*/
if (pngPtr->block.height > INT_MAX / pngPtr->block.pitch) {
- Tcl_SetResult(interp, "Image total size is out of supported range "
+ Tcl_SetResult(interp, "image total size is out of supported range "
"on this architecture", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "SIZE", NULL);
return TCL_ERROR;
}
@@ -1161,6 +1176,7 @@ CheckColor(
default:
Tcl_SetResult(interp, "internal error - unknown color type",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "UNKNOWN_COLOR", NULL);
return TCL_ERROR;
}
@@ -1240,8 +1256,9 @@ ReadIHDR(
}
if (mismatch) {
- Tcl_SetResult(interp, "Data stream does not have a PNG signature",
+ Tcl_SetResult(interp, "data stream does not have a PNG signature",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "NO_SIG", NULL);
return TCL_ERROR;
}
@@ -1257,12 +1274,14 @@ ReadIHDR(
*/
if (chunkType != CHUNK_IHDR) {
- Tcl_SetResult(interp, "Expected IHDR chunk type", TCL_STATIC);
+ Tcl_SetResult(interp, "expected IHDR chunk type", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "NO_IHDR", NULL);
return TCL_ERROR;
}
if (chunkSz != 13) {
- Tcl_SetResult(interp, "Invalid IHDR chunk size", TCL_STATIC);
+ Tcl_SetResult(interp, "invalid IHDR chunk size", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_IHDR", NULL);
return TCL_ERROR;
}
@@ -1282,8 +1301,9 @@ ReadIHDR(
if (!width || !height || (width > INT_MAX) || (height > INT_MAX)) {
Tcl_SetResult(interp,
- "Image dimensions are invalid or beyond architecture limits",
+ "image dimensions are invalid or beyond architecture limits",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "DIMENSIONS", NULL);
return TCL_ERROR;
}
@@ -1326,7 +1346,8 @@ ReadIHDR(
}
if (PNG_COMPRESS_DEFLATE != pngPtr->compression) {
- Tcl_SetResult(interp, "Unknown compression method", TCL_STATIC);
+ Tcl_SetResult(interp, "unknown compression method", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_COMPRESS", NULL);
return TCL_ERROR;
}
@@ -1340,7 +1361,8 @@ ReadIHDR(
}
if (PNG_FILTMETH_STANDARD != pngPtr->filter) {
- Tcl_SetResult(interp, "Unknown filter method", TCL_STATIC);
+ Tcl_SetResult(interp, "unknown filter method", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_FILTER", NULL);
return TCL_ERROR;
}
@@ -1354,7 +1376,8 @@ ReadIHDR(
break;
default:
- Tcl_SetResult(interp, "Unknown interlace method", TCL_STATIC);
+ Tcl_SetResult(interp, "unknown interlace method", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_INTERLACE", NULL);
return TCL_ERROR;
}
@@ -1399,6 +1422,8 @@ ReadPLTE(
case PNG_COLOR_GRAYALPHA:
Tcl_SetResult(interp, "PLTE chunk type forbidden for grayscale",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "PLTE_UNEXPECTED",
+ NULL);
return TCL_ERROR;
default:
@@ -1412,7 +1437,8 @@ ReadPLTE(
*/
if (!chunkSz || (chunkSz > PNG_PLTE_MAXSZ) || (chunkSz % 3)) {
- Tcl_SetResult(interp, "Invalid palette chunk size", TCL_STATIC);
+ Tcl_SetResult(interp, "invalid palette chunk size", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_PLTE", NULL);
return TCL_ERROR;
}
@@ -1477,6 +1503,7 @@ ReadTRNS(
Tcl_SetResult(interp,
"tRNS chunk not allowed color types with a full alpha channel",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "INVALID_TRNS", NULL);
return TCL_ERROR;
}
@@ -1486,7 +1513,8 @@ ReadTRNS(
*/
if (chunkSz > PNG_TRNS_MAXSZ) {
- Tcl_SetResult(interp, "Invalid tRNS chunk size", TCL_STATIC);
+ Tcl_SetResult(interp, "invalid tRNS chunk size", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_TRNS", NULL);
return TCL_ERROR;
}
@@ -1516,8 +1544,9 @@ ReadTRNS(
if (chunkSz > pngPtr->paletteLen) {
Tcl_SetResult(interp,
- "Size of tRNS chunk is too large for the palette",
+ "size of tRNS chunk is too large for the palette",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "TRNS_SIZE", NULL);
return TCL_ERROR;
}
@@ -1534,8 +1563,9 @@ ReadTRNS(
if (chunkSz != 2) {
Tcl_SetResult(interp,
- "Invalid tRNS chunk size - must 2 bytes for grayscale",
+ "invalid tRNS chunk size - must 2 bytes for grayscale",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_TRNS", NULL);
return TCL_ERROR;
}
@@ -1560,8 +1590,9 @@ ReadTRNS(
if (chunkSz != 6) {
Tcl_SetResult(interp,
- "Invalid tRNS chunk size - must 6 bytes for RGB",
+ "invalid tRNS chunk size - must 6 bytes for RGB",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_TRNS", NULL);
return TCL_ERROR;
}
@@ -1742,7 +1773,8 @@ UnfilterLine(
}
break;
default:
- Tcl_SetResult(interp, "Invalid filter type", TCL_STATIC);
+ Tcl_SetResult(interp, "invalid filter type", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_FILTER", NULL);
return TCL_ERROR;
}
@@ -2049,8 +2081,10 @@ ReadIDAT(
*/
if (Tcl_ZlibStreamEof(pngPtr->stream)) {
- Tcl_SetResult(interp, "Extra data after end of zlib stream",
+ Tcl_SetResult(interp, "extra data after end of zlib stream",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "EXTRA_DATA",
+ NULL);
return TCL_ERROR;
}
@@ -2090,8 +2124,10 @@ ReadIDAT(
if (len2 == pngPtr->phaseSize) {
if (pngPtr->phase > 7) {
Tcl_SetResult(interp,
- "Extra data after final scan line of final phase",
+ "extra data after final scan line of final phase",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "EXTRA_DATA",
+ NULL);
return TCL_ERROR;
}
@@ -2136,6 +2172,7 @@ ReadIDAT(
if (chunkSz != 0) {
Tcl_AppendResult(interp,
"compressed data after stream finalize in PNG data", NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "EXTRA_DATA", NULL);
return TCL_ERROR;
}
@@ -2274,6 +2311,8 @@ ParseFormat(
Tcl_SetResult(interp,
"-alpha value must be between 0.0 and 1.0",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_ALPHA",
+ NULL);
return TCL_ERROR;
}
break;
@@ -2365,6 +2404,7 @@ DecodePNG(
} else if (PNG_COLOR_PLTE == pngPtr->colorType) {
Tcl_SetResult(interp, "PLTE chunk required for indexed color",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "NEED_PLTE", NULL);
return TCL_ERROR;
}
@@ -2400,8 +2440,9 @@ DecodePNG(
*/
if (CHUNK_IDAT != chunkType) {
- Tcl_SetResult(interp, "At least one IDAT chunk is required",
+ Tcl_SetResult(interp, "at least one IDAT chunk is required",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "NEED_IDAT", NULL);
return TCL_ERROR;
}
@@ -2423,8 +2464,9 @@ DecodePNG(
if (pngPtr->block.width > ((INT_MAX - 1) / (pngPtr->numChannels * 2))) {
Tcl_SetResult(interp,
- "Line size is out of supported range on this architecture",
+ "line size is out of supported range on this architecture",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "LINE_SIZE", NULL);
return TCL_ERROR;
}
@@ -2449,7 +2491,8 @@ DecodePNG(
pngPtr->block.pixelPtr = attemptckalloc(pngPtr->blockLen);
if (!pngPtr->block.pixelPtr) {
- Tcl_SetResult(interp, "Memory allocation failed", TCL_STATIC);
+ Tcl_SetResult(interp, "memory allocation failed", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "MALLOC", NULL);
return TCL_ERROR;
}
@@ -2500,6 +2543,7 @@ DecodePNG(
if (!Tcl_ZlibStreamEof(pngPtr->stream)) {
Tcl_AppendResult(interp, "unfinalized data stream in PNG data", NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "EXTRA_DATA", NULL);
return TCL_ERROR;
}
@@ -2525,6 +2569,7 @@ DecodePNG(
if (chunkSz) {
Tcl_SetResult(interp, "IEND chunk contents must be empty",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_IEND", NULL);
return TCL_ERROR;
}
@@ -2543,7 +2588,8 @@ DecodePNG(
#if 0
if (ReadData(interp, pngPtr, &c, 1, NULL) != TCL_ERROR) {
- Tcl_SetResult(interp, "Extra data following IEND chunk", TCL_STATIC);
+ Tcl_SetResult(interp, "extra data following IEND chunk", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "BAD_IEND", NULL);
return TCL_ERROR;
}
#endif
@@ -2796,23 +2842,24 @@ WriteData(
if (objSz > INT_MAX - srcSz) {
Tcl_SetResult(interp,
- "Image too large to store completely in byte array",
+ "image too large to store completely in byte array",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "TOO_LARGE", NULL);
return TCL_ERROR;
}
destPtr = Tcl_SetByteArrayLength(pngPtr->objDataPtr, objSz + srcSz);
if (!destPtr) {
- Tcl_SetResult(interp, "Memory allocation failed", TCL_STATIC);
+ Tcl_SetResult(interp, "memory allocation failed", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "MALLOC", NULL);
return TCL_ERROR;
}
memcpy(destPtr+objSz, srcPtr, srcSz);
} else if (Tcl_Write(pngPtr->channel, (const char *) srcPtr, srcSz) < 0) {
- /* TODO: reason */
-
- Tcl_SetResult(interp, "Write to channel failed", TCL_STATIC);
+ Tcl_AppendResult(interp, "write to channel failed: ",
+ Tcl_PosixError(interp), NULL);
return TCL_ERROR;
}
@@ -3128,6 +3175,7 @@ WriteIDAT(
if (Tcl_ZlibStreamPut(pngPtr->stream, pngPtr->thisLineObj,
flush) != TCL_OK) {
Tcl_SetResult(interp, "deflate() returned error", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "DEFLATE", NULL);
return TCL_ERROR;
}
@@ -3301,8 +3349,9 @@ EncodePNG(
if ((blockPtr->width > (INT_MAX - 1) / (pngPtr->bytesPerPixel)) ||
(blockPtr->height > INT_MAX / pngPtr->lineSize)) {
- Tcl_SetResult(interp, "Image is too large to encode pixel data",
+ Tcl_SetResult(interp, "image is too large to encode pixel data",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PNG", "TOO_LARGE", NULL);
return TCL_ERROR;
}
diff --git a/generic/tkImgPPM.c b/generic/tkImgPPM.c
index 527efa2..0378d16 100644
--- a/generic/tkImgPPM.c
+++ b/generic/tkImgPPM.c
@@ -149,11 +149,13 @@ FileReadPPM(
if (type == 0) {
Tcl_AppendResult(interp, "couldn't read raw PPM header from file \"",
fileName, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "NO_HEADER", NULL);
return TCL_ERROR;
}
if ((fileWidth <= 0) || (fileHeight <= 0)) {
Tcl_AppendResult(interp, "PPM image file \"", fileName,
"\" has dimension(s) <= 0", NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "DIMENSIONS", NULL);
return TCL_ERROR;
}
if ((maxIntensity <= 0) || (maxIntensity >= 256)) {
@@ -162,6 +164,7 @@ FileReadPPM(
sprintf(buffer, "%d", maxIntensity);
Tcl_AppendResult(interp, "PPM image file \"", fileName,
"\" has bad maximum intensity value ", buffer, NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "INTENSITY", NULL);
return TCL_ERROR;
}
@@ -484,11 +487,13 @@ StringReadPPM(
if (type == 0) {
Tcl_AppendResult(interp, "couldn't read raw PPM header from string",
NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "NO_HEADER", NULL);
return TCL_ERROR;
}
if ((fileWidth <= 0) || (fileHeight <= 0)) {
Tcl_AppendResult(interp, "PPM image data has dimension(s) <= 0",
NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "DIMENSIONS", NULL);
return TCL_ERROR;
}
if ((maxIntensity <= 0) || (maxIntensity >= 256)) {
@@ -498,6 +503,7 @@ StringReadPPM(
Tcl_AppendResult(interp,
"PPM image data has bad maximum intensity value ", buffer,
NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "INTENSITY", NULL);
return TCL_ERROR;
}
@@ -539,6 +545,7 @@ StringReadPPM(
if (block.pitch*height > dataSize) {
Tcl_AppendResult(interp, "truncated PPM data", NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "TRUNCATED", NULL);
return TCL_ERROR;
}
block.pixelPtr = dataBuffer + srcX * block.pixelSize;
@@ -573,6 +580,7 @@ StringReadPPM(
if (dataSize < nBytes) {
ckfree(pixelPtr);
Tcl_AppendResult(interp, "truncated PPM data", NULL);
+ Tcl_SetErrorCode(interp, "TK", "IMAGE", "PPM", "TRUNCATED", NULL);
return TCL_ERROR;
}
for (p=pixelPtr,count=nBytes ; count>0 ; count--,p++,dataBuffer++) {
diff --git a/generic/tkImgPhoto.c b/generic/tkImgPhoto.c
index 5b172f1..d1e8524 100644
--- a/generic/tkImgPhoto.c
+++ b/generic/tkImgPhoto.c
@@ -565,6 +565,7 @@ ImgPhotoCmd(
Tcl_AppendResult(interp, "image \"",
Tcl_GetString(options.name), "\" doesn't",
" exist or is not a photo image", NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "PHOTO", NULL);
return TCL_ERROR;
}
Tk_PhotoGetImage(srcHandle, &block);
@@ -573,6 +574,7 @@ ImgPhotoCmd(
|| (options.fromY2 > block.height)) {
Tcl_AppendResult(interp, "coordinates for -from option extend ",
"outside source image", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "BAD_FROM", NULL);
return TCL_ERROR;
}
@@ -626,6 +628,7 @@ ImgPhotoCmd(
options.toY2) != TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, TK_PHOTO_ALLOC_FAILURE_MESSAGE, NULL);
+ Tcl_SetErrorCode(interp, "TK", "MALLOC", NULL);
return TCL_ERROR;
}
}
@@ -674,6 +677,7 @@ ImgPhotoCmd(
|| (options.fromY2 > masterPtr->height)) {
Tcl_AppendResult(interp, "coordinates for -from option extend ",
"outside image", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "BAD_FROM", NULL);
return TCL_ERROR;
}
@@ -722,6 +726,8 @@ ImgPhotoCmd(
Tcl_AppendResult(interp, "image string format \"",
Tcl_GetString(options.format), "\" is ",
(matched ? "not supported" : "unknown"), NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "PHOTO_FORMAT",
+ NULL);
return TCL_ERROR;
}
} else {
@@ -770,7 +776,7 @@ ImgPhotoCmd(
* photo get command - first parse and check parameters.
*/
- char string[TCL_INTEGER_SPACE * 3];
+ Tcl_Obj *channels[3];
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "x y");
@@ -784,6 +790,7 @@ ImgPhotoCmd(
|| (y < 0) || (y >= masterPtr->height)) {
Tcl_AppendResult(interp, Tcl_GetString(objv[0]), " get: ",
"coordinates out of range", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "COORDINATES", NULL);
return TCL_ERROR;
}
@@ -792,9 +799,10 @@ ImgPhotoCmd(
*/
pixelPtr = masterPtr->pix32 + (y * masterPtr->width + x) * 4;
- sprintf(string, "%d %d %d", pixelPtr[0], pixelPtr[1],
- pixelPtr[2]);
- Tcl_AppendResult(interp, string, NULL);
+ channels[0] = Tcl_NewIntObj(pixelPtr[0]);
+ channels[1] = Tcl_NewIntObj(pixelPtr[1]);
+ channels[2] = Tcl_NewIntObj(pixelPtr[2]);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(3, channels));
return TCL_OK;
}
@@ -878,6 +886,8 @@ ImgPhotoCmd(
} else if (listObjc != dataWidth) {
Tcl_AppendResult(interp, "all elements of color list must",
" have the same number of elements", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "NON_RECTANGULAR",
+ NULL);
break;
}
@@ -922,6 +932,7 @@ ImgPhotoCmd(
colorString, &color)) {
Tcl_AppendResult(interp, "can't parse color \"",
colorString, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "COLOR", NULL);
break;
}
*pixelPtr++ = color.red >> 8;
@@ -994,6 +1005,7 @@ ImgPhotoCmd(
if (Tcl_IsSafe(interp)) {
Tcl_AppendResult(interp, "can't get image from a file in a",
" safe interpreter", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "SAFE", NULL);
return TCL_ERROR;
}
@@ -1033,6 +1045,7 @@ ImgPhotoCmd(
|| (options.fromY2 > imageHeight)) {
Tcl_AppendResult(interp, "coordinates for -from option extend ",
"outside source image", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "BAD_FROM", NULL);
Tcl_Close(NULL, chan);
return TCL_ERROR;
}
@@ -1053,6 +1066,7 @@ ImgPhotoCmd(
options.toY + height) != TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, TK_PHOTO_ALLOC_FAILURE_MESSAGE, NULL);
+ Tcl_SetErrorCode(interp, "TK", "MALLOC", NULL);
return TCL_ERROR;
}
}
@@ -1145,6 +1159,7 @@ ImgPhotoCmd(
|| (y < 0) || (y >= masterPtr->height)) {
Tcl_AppendResult(interp, Tcl_GetString(objv[0]),
" transparency get: coordinates out of range", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "COORDINATES", NULL);
return TCL_ERROR;
}
@@ -1182,6 +1197,7 @@ ImgPhotoCmd(
|| (y < 0) || (y >= masterPtr->height)) {
Tcl_AppendResult(interp, Tcl_GetString(objv[0]),
" transparency set: coordinates out of range", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "COORDINATES", NULL);
return TCL_ERROR;
}
@@ -1246,6 +1262,7 @@ ImgPhotoCmd(
if (Tcl_IsSafe(interp)) {
Tcl_AppendResult(interp, "can't write image to a file in a",
" safe interpreter", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "SAFE", NULL);
return TCL_ERROR;
}
@@ -1272,6 +1289,7 @@ ImgPhotoCmd(
|| (options.fromY2 > masterPtr->height)) {
Tcl_AppendResult(interp, "coordinates for -from option extend ",
"outside image", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "BAD_FROM", NULL);
return TCL_ERROR;
}
@@ -1343,14 +1361,12 @@ ImgPhotoCmd(
} else if (!matched) {
Tcl_AppendResult(interp, "image file format \"",
fmtString, "\" is unknown", NULL);
- Tcl_SetErrorCode(interp, "TK", "LOOKUP", "PHOTO_FORMAT",
- fmtString, NULL);
} else {
Tcl_AppendResult(interp, "image file format \"",
fmtString, "\" has no file writing capability", NULL);
- Tcl_SetErrorCode(interp, "TK", "LOOKUP", "PHOTO_FORMAT",
- fmtString, NULL);
}
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "PHOTO_FORMAT",
+ fmtString, NULL);
return TCL_ERROR;
}
@@ -1502,6 +1518,7 @@ ParseSubcommandOptions(
}
bit <<= 1;
}
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "PHOTO_OPTION", NULL);
return TCL_ERROR;
}
@@ -1525,6 +1542,8 @@ ParseSubcommandOptions(
} else {
Tcl_AppendResult(interp, "the \"-background\" option ",
"requires a value", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "MISSING_VALUE",
+ NULL);
return TCL_ERROR;
}
} else if (bit == OPT_FORMAT) {
@@ -1539,6 +1558,8 @@ ParseSubcommandOptions(
} else {
Tcl_AppendResult(interp, "the \"-format\" option ",
"requires a value", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "MISSING_VALUE",
+ NULL);
return TCL_ERROR;
}
} else if (bit == OPT_COMPOSITE) {
@@ -1567,6 +1588,8 @@ ParseSubcommandOptions(
} else {
Tcl_AppendResult(interp, "the \"-compositingrule\" option ",
"requires a value", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "MISSING_VALUE",
+ NULL);
return TCL_ERROR;
}
} else if ((bit != OPT_SHRINK) && (bit != OPT_GRAYSCALE)) {
@@ -1594,6 +1617,8 @@ ParseSubcommandOptions(
Tcl_AppendResult(interp, "the \"", option, "\" option ",
"requires one ", maxValues == 2? "or two": "to four",
" integer values", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "MISSING_VALUE",
+ NULL);
return TCL_ERROR;
}
*optIndexPtr = (index += numValues);
@@ -1620,6 +1645,7 @@ ParseSubcommandOptions(
&& ((values[2] < 0) || (values[3] < 0)))) {
Tcl_AppendResult(interp, "value(s) for the -from",
" option must be non-negative", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "BAD_FROM", NULL);
return TCL_ERROR;
}
if (numValues <= 2) {
@@ -1643,6 +1669,7 @@ ParseSubcommandOptions(
&& ((values[2] < 0) || (values[3] < 0)))) {
Tcl_AppendResult(interp, "value(s) for the -to",
" option must be non-negative", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "BAD_TO", NULL);
return TCL_ERROR;
}
if (numValues <= 2) {
@@ -1661,6 +1688,7 @@ ParseSubcommandOptions(
if ((values[0] <= 0) || (values[1] <= 0)) {
Tcl_AppendResult(interp, "value(s) for the -zoom",
" option must be positive", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "BAD_ZOOM", NULL);
return TCL_ERROR;
}
optPtr->zoomX = values[0];
@@ -1732,6 +1760,8 @@ ImgPhotoConfigureMaster(
ckfree(args);
Tcl_AppendResult(interp,
"value for \"-data\" missing", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "MISSING_VALUE",
+ NULL);
return TCL_ERROR;
}
} else if ((args[j][1] == 'f') &&
@@ -1743,6 +1773,8 @@ ImgPhotoConfigureMaster(
ckfree(args);
Tcl_AppendResult(interp,
"value for \"-format\" missing", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "MISSING_VALUE",
+ NULL);
return TCL_ERROR;
}
}
@@ -1834,6 +1866,7 @@ ImgPhotoConfigureMaster(
masterPtr->height) != TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, TK_PHOTO_ALLOC_FAILURE_MESSAGE, NULL);
+ Tcl_SetErrorCode(interp, "TK", "MALLOC", NULL);
goto errorExit;
}
@@ -1853,6 +1886,7 @@ ImgPhotoConfigureMaster(
Tcl_ResetResult(interp);
Tcl_AppendResult(interp,
"can't get image from a file in a safe interpreter", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "SAFE", NULL);
goto errorExit;
}
@@ -1878,6 +1912,7 @@ ImgPhotoConfigureMaster(
Tcl_Close(NULL, chan);
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, TK_PHOTO_ALLOC_FAILURE_MESSAGE, NULL);
+ Tcl_SetErrorCode(interp, "TK", "MALLOC", NULL);
goto errorExit;
}
tempformat = masterPtr->format;
@@ -1908,6 +1943,7 @@ ImgPhotoConfigureMaster(
if (ImgPhotoSetSize(masterPtr, imageWidth, imageHeight) != TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, TK_PHOTO_ALLOC_FAILURE_MESSAGE, NULL);
+ Tcl_SetErrorCode(interp, "TK", "MALLOC", NULL);
goto errorExit;
}
tempformat = masterPtr->format;
@@ -2353,6 +2389,8 @@ MatchFileFormat(
if (formatPtr->fileMatchProc == NULL) {
Tcl_AppendResult(interp, "-file option isn't supported for ",
formatString, " images", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "NOT_FILE_FORMAT",
+ NULL);
return TCL_ERROR;
}
}
@@ -2384,6 +2422,8 @@ MatchFileFormat(
if (formatPtr->fileMatchProc == NULL) {
Tcl_AppendResult(interp, "-file option isn't supported",
" for ", formatString, " images", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "NOT_FILE_FORMAT",
+ NULL);
return TCL_ERROR;
}
}
@@ -2407,10 +2447,13 @@ MatchFileFormat(
if ((formatObj != NULL) && !matched) {
Tcl_AppendResult(interp, "image file format \"", formatString,
"\" is not supported", NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "PHOTO_FORMAT", NULL);
} else {
Tcl_AppendResult(interp,
"couldn't recognize data in image file \"", fileName, "\"",
NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "UNRECOGNIZED_DATA",
+ NULL);
}
return TCL_ERROR;
}
@@ -2482,6 +2525,8 @@ MatchStringFormat(
if (formatPtr->stringMatchProc == NULL) {
Tcl_AppendResult(interp, "-data option isn't supported for ",
formatString, " images", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "NOT_DATA_FORMAT",
+ NULL);
return TCL_ERROR;
}
}
@@ -2506,6 +2551,8 @@ MatchStringFormat(
if (formatPtr->stringMatchProc == NULL) {
Tcl_AppendResult(interp, "-data option isn't supported",
" for ", formatString, " images", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "NOT_DATA_FORMAT",
+ NULL);
return TCL_ERROR;
}
}
@@ -2523,8 +2570,11 @@ MatchStringFormat(
if ((formatObj != NULL) && !matched) {
Tcl_AppendResult(interp, "image format \"", formatString,
"\" is not supported", NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "PHOTO_FORMAT", NULL);
} else {
Tcl_AppendResult(interp, "couldn't recognize image data", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PHOTO", "UNRECOGNIZED_DATA",
+ NULL);
}
return TCL_ERROR;
}
@@ -2643,6 +2693,7 @@ Tk_PhotoPutBlock(
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, TK_PHOTO_ALLOC_FAILURE_MESSAGE, NULL);
+ Tcl_SetErrorCode(interp, "TK", "MALLOC", NULL);
}
return TCL_ERROR;
}
@@ -3039,6 +3090,7 @@ Tk_PhotoPutZoomedBlock(
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, TK_PHOTO_ALLOC_FAILURE_MESSAGE, NULL);
+ Tcl_SetErrorCode(interp, "TK", "MALLOC", NULL);
}
return TCL_ERROR;
}
@@ -3437,6 +3489,7 @@ Tk_PhotoExpand(
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, TK_PHOTO_ALLOC_FAILURE_MESSAGE, NULL);
+ Tcl_SetErrorCode(interp, "TK", "MALLOC", NULL);
}
return TCL_ERROR;
}
@@ -3511,6 +3564,7 @@ Tk_PhotoSetSize(
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, TK_PHOTO_ALLOC_FAILURE_MESSAGE, NULL);
+ Tcl_SetErrorCode(interp, "TK", "MALLOC", NULL);
}
return TCL_ERROR;
}
diff --git a/generic/tkListbox.c b/generic/tkListbox.c
index 7faa44b..e8817af 100644
--- a/generic/tkListbox.c
+++ b/generic/tkListbox.c
@@ -168,6 +168,13 @@ typedef struct {
} Listbox;
/*
+ * How to encode the keys for the hash tables used to store what items are
+ * selected and what the attributes are.
+ */
+
+#define KEY(i) ((char *) INT2PTR(i))
+
+/*
* ItemAttr structures are used to store item configuration information for
* the items in a listbox
*/
@@ -437,8 +444,8 @@ static void MigrateHashEntries(Tcl_HashTable *table,
static const Tk_ClassProcs listboxClass = {
sizeof(Tk_ClassProcs), /* size */
ListboxWorldChanged, /* worldChangedProc */
- NULL, /* createProc */
- NULL /* modalProc */
+ NULL, /* createProc */
+ NULL /* modalProc */
};
/*
@@ -480,8 +487,7 @@ Tk_ListboxObjCmd(
return TCL_ERROR;
}
- optionTables = (ListboxOptionTables *)
- Tcl_GetAssocData(interp, "ListboxOptionTables", NULL);
+ optionTables = Tcl_GetAssocData(interp, "ListboxOptionTables", NULL);
if (optionTables == NULL) {
/*
* We haven't created the option tables for this widget class yet. Do
@@ -515,7 +521,7 @@ Tk_ListboxObjCmd(
*/
listPtr = ckalloc(sizeof(Listbox));
- memset(listPtr, 0, (sizeof(Listbox)));
+ memset(listPtr, 0, sizeof(Listbox));
listPtr->tkwin = tkwin;
listPtr->display = Tk_Display(tkwin);
@@ -597,6 +603,7 @@ ListboxWidgetObjCmd(
register Listbox *listPtr = clientData;
int cmdIndex, index;
int result = TCL_OK;
+ Tcl_Obj *objPtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
@@ -661,9 +668,7 @@ ListboxWidgetObjCmd(
result = ListboxBboxSubCmd(interp, listPtr, index);
break;
- case COMMAND_CGET: {
- Tcl_Obj *objPtr;
-
+ case COMMAND_CGET:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "option");
result = TCL_ERROR;
@@ -679,11 +684,8 @@ ListboxWidgetObjCmd(
Tcl_SetObjResult(interp, objPtr);
result = TCL_OK;
break;
- }
-
- case COMMAND_CONFIGURE: {
- Tcl_Obj *objPtr;
+ case COMMAND_CONFIGURE:
if (objc <= 3) {
objPtr = Tk_GetOptionInfo(interp, (char *) listPtr,
listPtr->optionTable,
@@ -698,10 +700,8 @@ ListboxWidgetObjCmd(
result = ConfigureListbox(interp, listPtr, objc-2, objv+2, 0);
}
break;
- }
case COMMAND_CURSELECTION: {
- char indexStringRep[TCL_INTEGER_SPACE];
int i;
if (objc != 2) {
@@ -718,12 +718,13 @@ ListboxWidgetObjCmd(
* selected.
*/
+ objPtr = Tcl_NewObj();
for (i = 0; i < listPtr->nElements; i++) {
- if (Tcl_FindHashEntry(listPtr->selection, (char *) INT2PTR(i))) {
- sprintf(indexStringRep, "%d", i);
- Tcl_AppendElement(interp, indexStringRep);
+ if (Tcl_FindHashEntry(listPtr->selection, KEY(i))) {
+ Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewIntObj(i));
}
}
+ Tcl_SetObjResult(interp, objPtr);
result = TCL_OK;
break;
}
@@ -857,7 +858,6 @@ ListboxWidgetObjCmd(
break;
case COMMAND_ITEMCGET: {
- Tcl_Obj *objPtr;
ItemAttr *attrPtr;
if (objc != 4) {
@@ -892,7 +892,6 @@ ListboxWidgetObjCmd(
}
case COMMAND_ITEMCONFIGURE: {
- Tcl_Obj *objPtr;
ItemAttr *attrPtr;
if (objc < 3) {
@@ -922,10 +921,9 @@ ListboxWidgetObjCmd(
if (objPtr == NULL) {
result = TCL_ERROR;
break;
- } else {
- Tcl_SetObjResult(interp, objPtr);
- result = TCL_OK;
}
+ Tcl_SetObjResult(interp, objPtr);
+ result = TCL_OK;
} else {
result = ConfigureListboxItem(interp, listPtr, attrPtr,
objc-3, objv+3, index);
@@ -1007,7 +1005,7 @@ ListboxWidgetObjCmd(
}
diff = listPtr->topIndex - index;
if (diff > 0) {
- if (diff <= (listPtr->fullLines/3)) {
+ if (diff <= listPtr->fullLines / 3) {
ChangeListboxView(listPtr, index);
} else {
ChangeListboxView(listPtr, index - (listPtr->fullLines-1)/2);
@@ -1015,7 +1013,7 @@ ListboxWidgetObjCmd(
} else {
diff = index - (listPtr->topIndex + listPtr->fullLines - 1);
if (diff > 0) {
- if (diff <= (listPtr->fullLines/3)) {
+ if (diff <= listPtr->fullLines / 3) {
ChangeListboxView(listPtr, listPtr->topIndex + diff);
} else {
ChangeListboxView(listPtr, index-(listPtr->fullLines-1)/2);
@@ -1090,7 +1088,7 @@ ListboxBboxSubCmd(
*/
if ((listPtr->topIndex <= index) && (index < lastVisibleIndex)) {
- Tcl_Obj *el;
+ Tcl_Obj *el, *results[4];
const char *stringRep;
int pixelWidth, stringLen, x, y, result;
Tk_FontMetrics fm;
@@ -1111,8 +1109,11 @@ ListboxBboxSubCmd(
x = listPtr->inset + listPtr->selBorderWidth - listPtr->xOffset;
y = ((index - listPtr->topIndex)*listPtr->lineHeight)
+ listPtr->inset + listPtr->selBorderWidth;
- Tcl_SetObjResult(interp, Tcl_ObjPrintf("%d %d %d %d",
- x, y, pixelWidth, fm.linespace));
+ results[0] = Tcl_NewIntObj(x);
+ results[1] = Tcl_NewIntObj(y);
+ results[2] = Tcl_NewIntObj(pixelWidth);
+ results[3] = Tcl_NewIntObj(fm.linespace);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(4, results));
}
return TCL_OK;
}
@@ -1197,9 +1198,8 @@ ListboxSelectionSubCmd(
Tcl_WrongNumArgs(interp, 3, objv, "index");
return TCL_ERROR;
}
- Tcl_SetObjResult(interp,
- Tcl_NewBooleanObj((Tcl_FindHashEntry(listPtr->selection,
- (char *) INT2PTR(first)) != NULL)));
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
+ Tcl_FindHashEntry(listPtr->selection, KEY(first)) != NULL));
result = TCL_OK;
break;
case SELECTION_SET:
@@ -1232,43 +1232,45 @@ ListboxXviewSubCmd(
int objc, /* Number of arguments in the objv array */
Tcl_Obj *const objv[]) /* Array of arguments to the procedure */
{
-
- int index, count, type, windowWidth, windowUnits;
+ int index, count, windowWidth, windowUnits;
int offset = 0; /* Initialized to stop gcc warnings. */
double fraction;
windowWidth = Tk_Width(listPtr->tkwin)
- 2*(listPtr->inset + listPtr->selBorderWidth);
if (objc == 2) {
+ Tcl_Obj *results[2];
+
if (listPtr->maxWidth == 0) {
- Tcl_SetResult(interp, "0.0 1.0", TCL_STATIC);
+ results[0] = Tcl_NewDoubleObj(0.0);
+ results[1] = Tcl_NewDoubleObj(1.0);
} else {
double fraction2;
- fraction = listPtr->xOffset/((double) listPtr->maxWidth);
+ fraction = listPtr->xOffset / (double) listPtr->maxWidth;
fraction2 = (listPtr->xOffset + windowWidth)
- / ((double) listPtr->maxWidth);
+ / (double) listPtr->maxWidth;
if (fraction2 > 1.0) {
fraction2 = 1.0;
}
- Tcl_SetObjResult(interp, Tcl_ObjPrintf("%g %g",
- fraction, fraction2));
+ results[0] = Tcl_NewDoubleObj(fraction);
+ results[1] = Tcl_NewDoubleObj(fraction2);
}
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, results));
} else if (objc == 3) {
if (Tcl_GetIntFromObj(interp, objv[2], &index) != TCL_OK) {
return TCL_ERROR;
}
ChangeListboxOffset(listPtr, index*listPtr->xScrollUnit);
} else {
- type = Tk_GetScrollInfoObj(interp, objc, objv, &fraction, &count);
- switch (type) {
+ switch (Tk_GetScrollInfoObj(interp, objc, objv, &fraction, &count)) {
case TK_SCROLL_ERROR:
return TCL_ERROR;
case TK_SCROLL_MOVETO:
offset = (int) (fraction*listPtr->maxWidth + 0.5);
break;
case TK_SCROLL_PAGES:
- windowUnits = windowWidth/listPtr->xScrollUnit;
+ windowUnits = windowWidth / listPtr->xScrollUnit;
if (windowUnits > 2) {
offset = listPtr->xOffset
+ count*listPtr->xScrollUnit*(windowUnits-2);
@@ -1308,12 +1310,15 @@ ListboxYviewSubCmd(
int objc, /* Number of arguments in the objv array */
Tcl_Obj *const objv[]) /* Array of arguments to the procedure */
{
- int index, count, type;
+ int index, count;
double fraction;
if (objc == 2) {
+ Tcl_Obj *results[2];
+
if (listPtr->nElements == 0) {
- Tcl_SetResult(interp, "0.0 1.0", TCL_STATIC);
+ results[0] = Tcl_NewDoubleObj(0.0);
+ results[1] = Tcl_NewDoubleObj(1.0);
} else {
double fraction2, numEls = (double) listPtr->nElements;
@@ -1322,17 +1327,17 @@ ListboxYviewSubCmd(
if (fraction2 > 1.0) {
fraction2 = 1.0;
}
- Tcl_SetObjResult(interp, Tcl_ObjPrintf("%g %g",
- fraction, fraction2));
+ results[0] = Tcl_NewDoubleObj(fraction);
+ results[1] = Tcl_NewDoubleObj(fraction2);
}
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, results));
} else if (objc == 3) {
if (GetListboxIndex(interp, listPtr, objv[2], 0, &index) != TCL_OK) {
return TCL_ERROR;
}
ChangeListboxView(listPtr, index);
} else {
- type = Tk_GetScrollInfoObj(interp, objc, objv, &fraction, &count);
- switch (type) {
+ switch (Tk_GetScrollInfoObj(interp, objc, objv, &fraction, &count)) {
case TK_SCROLL_MOVETO:
index = (int) (listPtr->nElements*fraction + 0.5);
break;
@@ -1383,8 +1388,7 @@ ListboxGetItemAttributes(
Tcl_HashEntry *entry;
ItemAttr *attrs;
- entry = Tcl_CreateHashEntry(listPtr->itemAttrTable,
- (char *) INT2PTR(index), &isNew);
+ entry = Tcl_CreateHashEntry(listPtr->itemAttrTable, KEY(index), &isNew);
if (isNew) {
attrs = ckalloc(sizeof(ItemAttr));
attrs->border = NULL;
@@ -1910,7 +1914,7 @@ DisplayListbox(
* special foreground/background colors.
*/
- entry = Tcl_FindHashEntry(listPtr->itemAttrTable, (char *) INT2PTR(i));
+ entry = Tcl_FindHashEntry(listPtr->itemAttrTable, KEY(i));
/*
* If the listbox is enabled, items may be drawn differently; they may
@@ -1919,7 +1923,7 @@ DisplayListbox(
*/
if (listPtr->state & STATE_NORMAL) {
- if (Tcl_FindHashEntry(listPtr->selection, (char *) INT2PTR(i))) {
+ if (Tcl_FindHashEntry(listPtr->selection, KEY(i))) {
/*
* Selected items are drawn differently.
*/
@@ -2001,8 +2005,7 @@ DisplayListbox(
}
/* Draw bottom bevel */
if (i + 1 == listPtr->nElements ||
- Tcl_FindHashEntry(listPtr->selection,
- (char *) INT2PTR(i + 1)) == NULL ) {
+ !Tcl_FindHashEntry(listPtr->selection, KEY(i + 1))) {
Tk_3DHorizontalBevel(tkwin, pixmap, selectedBg, x-left,
y + listPtr->lineHeight - listPtr->selBorderWidth,
width+left+right, listPtr->selBorderWidth, 0, 0, 0,
@@ -2238,7 +2241,7 @@ ListboxComputeGeometry(
width = listPtr->width;
if (width <= 0) {
width = (listPtr->maxWidth + listPtr->xScrollUnit - 1)
- /listPtr->xScrollUnit;
+ / listPtr->xScrollUnit;
if (width < 1) {
width = 1;
}
@@ -2439,13 +2442,13 @@ ListboxDeleteSubCmd(
* Remove selection information.
*/
- entry = Tcl_FindHashEntry(listPtr->selection, (char *) INT2PTR(i));
+ entry = Tcl_FindHashEntry(listPtr->selection, KEY(i));
if (entry != NULL) {
listPtr->numSelected--;
Tcl_DeleteHashEntry(entry);
}
- entry = Tcl_FindHashEntry(listPtr->itemAttrTable, (char *) INT2PTR(i));
+ entry = Tcl_FindHashEntry(listPtr->itemAttrTable, KEY(i));
if (entry != NULL) {
ckfree(Tcl_GetHashValue(entry));
Tcl_DeleteHashEntry(entry);
@@ -2903,7 +2906,7 @@ ListboxScanTo(
*/
newTopIndex = listPtr->scanMarkYIndex
- - (10*(y - listPtr->scanMarkY))/listPtr->lineHeight;
+ - (10*(y - listPtr->scanMarkY)) / listPtr->lineHeight;
if (newTopIndex > maxIndex) {
newTopIndex = listPtr->scanMarkYIndex = maxIndex;
listPtr->scanMarkY = y;
@@ -2955,7 +2958,7 @@ NearestListboxElement(
{
int index;
- index = (y - listPtr->inset)/listPtr->lineHeight;
+ index = (y - listPtr->inset) / listPtr->lineHeight;
if (index >= (listPtr->fullLines + listPtr->partialLine)) {
index = listPtr->fullLines + listPtr->partialLine - 1;
}
@@ -3026,7 +3029,7 @@ ListboxSelect(
*/
for (i = first; i <= last; i++) {
- entry = Tcl_FindHashEntry(listPtr->selection, (char *) INT2PTR(i));
+ entry = Tcl_FindHashEntry(listPtr->selection, KEY(i));
if (entry != NULL) {
if (!select) {
Tcl_DeleteHashEntry(entry);
@@ -3037,8 +3040,8 @@ ListboxSelect(
}
} else {
if (select) {
- entry = Tcl_CreateHashEntry(listPtr->selection,
- (char *) INT2PTR(i), &isNew);
+ entry = Tcl_CreateHashEntry(listPtr->selection, KEY(i),
+ &isNew);
Tcl_SetHashValue(entry, NULL);
listPtr->numSelected++;
if (firstRedisplay < 0) {
@@ -3052,7 +3055,7 @@ ListboxSelect(
EventuallyRedrawRange(listPtr, first, last);
}
if ((oldCount == 0) && (listPtr->numSelected > 0)
- && (listPtr->exportSelection)) {
+ && listPtr->exportSelection) {
Tk_OwnSelection(listPtr->tkwin, XA_PRIMARY,
ListboxLostSelection, listPtr);
}
@@ -3109,7 +3112,7 @@ ListboxFetchSelection(
needNewline = 0;
Tcl_DStringInit(&selection);
for (i = 0; i < listPtr->nElements; i++) {
- entry = Tcl_FindHashEntry(listPtr->selection, (char *) INT2PTR(i));
+ entry = Tcl_FindHashEntry(listPtr->selection, KEY(i));
if (entry != NULL) {
if (needNewline) {
Tcl_DStringAppend(&selection, "\n", 1);
@@ -3250,9 +3253,9 @@ ListboxUpdateVScrollbar(
first = 0.0;
last = 1.0;
} else {
- first = listPtr->topIndex / ((double) listPtr->nElements);
+ first = listPtr->topIndex / (double) listPtr->nElements;
last = (listPtr->topIndex + listPtr->fullLines)
- / ((double) listPtr->nElements);
+ / (double) listPtr->nElements;
if (last > 1.0) {
last = 1.0;
}
@@ -3309,15 +3312,15 @@ ListboxUpdateHScrollbar(
if (listPtr->xScrollCmd == NULL) {
return;
}
- windowWidth = Tk_Width(listPtr->tkwin) - 2*(listPtr->inset
- + listPtr->selBorderWidth);
+
+ windowWidth = Tk_Width(listPtr->tkwin)
+ - 2*(listPtr->inset + listPtr->selBorderWidth);
if (listPtr->maxWidth == 0) {
first = 0;
last = 1.0;
} else {
- first = listPtr->xOffset/((double) listPtr->maxWidth);
- last = (listPtr->xOffset + windowWidth)
- /((double) listPtr->maxWidth);
+ first = listPtr->xOffset / (double) listPtr->maxWidth;
+ last = (listPtr->xOffset + windowWidth) / (double) listPtr->maxWidth;
if (last > 1.0) {
last = 1.0;
}
@@ -3429,7 +3432,7 @@ ListboxListVarProc(
* Clean up selection.
*/
- entry = Tcl_FindHashEntry(listPtr->selection, (char *) INT2PTR(i));
+ entry = Tcl_FindHashEntry(listPtr->selection, KEY(i));
if (entry != NULL) {
listPtr->numSelected--;
Tcl_DeleteHashEntry(entry);
@@ -3439,8 +3442,7 @@ ListboxListVarProc(
* Clean up attributes.
*/
- entry = Tcl_FindHashEntry(listPtr->itemAttrTable,
- (char *) INT2PTR(i));
+ entry = Tcl_FindHashEntry(listPtr->itemAttrTable, KEY(i));
if (entry != NULL) {
ckfree(Tcl_GetHashValue(entry));
Tcl_DeleteHashEntry(entry);
@@ -3514,23 +3516,21 @@ MigrateHashEntries(
if (offset > 0) {
for (i = last; i >= first; i--) {
- entry = Tcl_FindHashEntry(table, (char *) INT2PTR(i));
+ entry = Tcl_FindHashEntry(table, KEY(i));
if (entry != NULL) {
clientData = Tcl_GetHashValue(entry);
Tcl_DeleteHashEntry(entry);
- entry = Tcl_CreateHashEntry(table,
- (char *) INT2PTR(i + offset), &isNew);
+ entry = Tcl_CreateHashEntry(table, KEY(i + offset), &isNew);
Tcl_SetHashValue(entry, clientData);
}
}
} else {
for (i = first; i <= last; i++) {
- entry = Tcl_FindHashEntry(table, (char *) INT2PTR(i));
+ entry = Tcl_FindHashEntry(table, KEY(i));
if (entry != NULL) {
clientData = Tcl_GetHashValue(entry);
Tcl_DeleteHashEntry(entry);
- entry = Tcl_CreateHashEntry(table,
- (char *) INT2PTR(i + offset), &isNew);
+ entry = Tcl_CreateHashEntry(table, KEY(i + offset), &isNew);
Tcl_SetHashValue(entry, clientData);
}
}
diff --git a/generic/tkObj.c b/generic/tkObj.c
index 8877d42..29a235a 100644
--- a/generic/tkObj.c
+++ b/generic/tkObj.c
@@ -506,6 +506,7 @@ SetPixelFromAny(
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad screen distance \"%.50s\"", string));
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "PIXELS", NULL);
}
return TCL_ERROR;
}
@@ -736,6 +737,7 @@ SetMMFromAny(
error:
Tcl_AppendResult(interp, "bad screen distance \"", string,
"\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "DISTANCE", NULL);
return TCL_ERROR;
}
while ((*rest != '\0') && isspace(UCHAR(*rest))) {
@@ -1036,6 +1038,7 @@ TkParsePadAmount(
Tcl_AppendResult(interp, "bad pad value \"",
Tcl_GetString(specObj),
"\": must be positive screen distance", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "PADDING", "DIST", NULL);
return TCL_ERROR;
}
secondInt = firstInt;
@@ -1053,6 +1056,7 @@ TkParsePadAmount(
if (objc != 1 && objc != 2) {
Tcl_AppendResult(interp,
"wrong number of parts to pad specification", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "PADDING", "PARTS", NULL);
return TCL_ERROR;
}
@@ -1065,6 +1069,7 @@ TkParsePadAmount(
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "bad pad value \"", Tcl_GetString(objv[0]),
"\": must be positive screen distance", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "PADDING", "DIST", NULL);
return TCL_ERROR;
}
@@ -1081,6 +1086,7 @@ TkParsePadAmount(
Tcl_AppendResult(interp, "bad 2nd pad value \"",
Tcl_GetString(objv[1]),
"\": must be positive screen distance", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "PADDING", "DIST", NULL);
return TCL_ERROR;
}
diff --git a/generic/tkOldConfig.c b/generic/tkOldConfig.c
index 1ab6ab6..49d505e 100644
--- a/generic/tkOldConfig.c
+++ b/generic/tkOldConfig.c
@@ -96,6 +96,7 @@ Tk_ConfigureWidget(
*/
Tcl_AppendResult(interp, "NULL main window", NULL);
+ Tcl_SetErrorCode(interp, "TK", "NO_MAIN_WINDOW", NULL);
return TCL_ERROR;
}
@@ -136,6 +137,7 @@ Tk_ConfigureWidget(
if (argc < 2) {
Tcl_AppendResult(interp, "value for \"", arg, "\" missing", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE_MISSING", NULL);
return TCL_ERROR;
}
if (flags & TK_CONFIG_OBJS) {
@@ -144,11 +146,8 @@ Tk_ConfigureWidget(
arg = argv[1];
}
if (DoConfig(interp, tkwin, specPtr, arg, 0, widgRec) != TCL_OK) {
- char msg[100];
-
- sprintf(msg, "\n (processing \"%.40s\" option)",
- specPtr->argvName);
- Tcl_AddErrorInfo(interp, msg);
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (processing \"%.40s\" option)",specPtr->argvName));
return TCL_ERROR;
}
if (!(flags & TK_CONFIG_ARGV_ONLY)) {
@@ -181,12 +180,10 @@ Tk_ConfigureWidget(
if (value != NULL) {
if (DoConfig(interp, tkwin, specPtr, value, 1, widgRec) !=
TCL_OK) {
- char msg[200];
-
- sprintf(msg, "\n (%s \"%.50s\" in widget \"%.50s\")",
- "database entry for",
- specPtr->dbName, Tk_PathName(tkwin));
- Tcl_AddErrorInfo(interp, msg);
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (%s \"%.50s\" in widget \"%.50s\")",
+ "database entry for", specPtr->dbName,
+ Tk_PathName(tkwin)));
return TCL_ERROR;
}
} else {
@@ -199,13 +196,10 @@ Tk_ConfigureWidget(
& TK_CONFIG_DONT_SET_DEFAULT)) {
if (DoConfig(interp, tkwin, specPtr, value, 1, widgRec) !=
TCL_OK) {
- char msg[200];
-
- sprintf(msg,
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (%s \"%.50s\" in widget \"%.50s\")",
- "default value for",
- specPtr->dbName, Tk_PathName(tkwin));
- Tcl_AddErrorInfo(interp, msg);
+ "default value for", specPtr->dbName,
+ Tk_PathName(tkwin)));
return TCL_ERROR;
}
}
@@ -274,6 +268,7 @@ FindConfigSpec(
if (matchPtr != NULL) {
Tcl_AppendResult(interp, "ambiguous option \"", argvName,
"\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "OPTION", argvName,NULL);
return NULL;
}
matchPtr = specPtr;
@@ -281,6 +276,7 @@ FindConfigSpec(
if (matchPtr == NULL) {
Tcl_AppendResult(interp, "unknown option \"", argvName, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "OPTION", argvName, NULL);
return NULL;
}
@@ -296,6 +292,8 @@ FindConfigSpec(
if (specPtr->type == TK_CONFIG_END) {
Tcl_AppendResult(interp, "couldn't find synonym for option \"",
argvName, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "OPTION", argvName,
+ NULL);
return NULL;
}
if ((specPtr->dbName == matchPtr->dbName)
@@ -546,14 +544,12 @@ DoConfig(
return TCL_ERROR;
}
break;
- default: {
- char buf[64 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "bad config table: unknown type %d", specPtr->type);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ default:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad config table: unknown type %d", specPtr->type));
+ Tcl_SetErrorCode(interp, "TK", "BAD_CONFIG", NULL);
return TCL_ERROR;
}
- }
specPtr++;
} while ((specPtr->argvName == NULL) && (specPtr->type != TK_CONFIG_END));
return TCL_OK;
diff --git a/generic/tkOption.c b/generic/tkOption.c
index d5c423f..a258bb0 100644
--- a/generic/tkOption.c
+++ b/generic/tkOption.c
@@ -541,7 +541,7 @@ Tk_GetOption(
winClassId = Tk_GetUid(masqClass);
ckfree(masqClass);
- winNameId = ((TkWindow *)tkwin)->nameUid;
+ winNameId = ((TkWindow *) tkwin)->nameUid;
levelPtr = &tsdPtr->levels[tsdPtr->curLevel];
@@ -619,11 +619,9 @@ Tk_OptionObjCmd(
int index, result;
ThreadSpecificData *tsdPtr =
Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
-
static const char *const optionCmds[] = {
"add", "clear", "get", "readfile", NULL
};
-
enum optionVals {
OPTION_ADD, OPTION_CLEAR, OPTION_GET, OPTION_READFILE
};
@@ -663,13 +661,12 @@ Tk_OptionObjCmd(
}
case OPTION_CLEAR: {
- TkMainInfo *mainPtr;
+ TkMainInfo *mainPtr = ((TkWindow *) tkwin)->mainPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, "");
return TCL_ERROR;
}
- mainPtr = ((TkWindow *) tkwin)->mainPtr;
if (mainPtr->optionRootPtr != NULL) {
ClearOptionTree(mainPtr->optionRootPtr);
mainPtr->optionRootPtr = NULL;
@@ -883,6 +880,7 @@ ParsePriority(
Tcl_AppendResult(interp, "bad priority level \"", string,
"\": must be widgetDefault, startupFile, userDefault, ",
"interactive, or a number between 0 and 100", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "PRIORITY", NULL);
return -1;
}
}
@@ -964,10 +962,9 @@ AddFromString(
dst = name = src;
while (*src != ':') {
if ((*src == '\0') || (*src == '\n')) {
- char buf[32 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "missing colon on line %d", lineNum);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing colon on line %d", lineNum));
+ Tcl_SetErrorCode(interp, "TK", "OPTIONDB", "COLON", NULL);
return TCL_ERROR;
}
if ((src[0] == '\\') && (src[1] == '\n')) {
@@ -999,10 +996,9 @@ AddFromString(
src++;
}
if (*src == '\0') {
- char buf[32 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "missing value on line %d", lineNum);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing value on line %d", lineNum));
+ Tcl_SetErrorCode(interp, "TK", "OPTIONDB", "VALUE", NULL);
return TCL_ERROR;
}
@@ -1014,10 +1010,9 @@ AddFromString(
dst = value = src;
while (*src != '\n') {
if (*src == '\0') {
- char buf[32 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "missing newline on line %d", lineNum);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing newline on line %d", lineNum));
+ Tcl_SetErrorCode(interp, "TK", "OPTIONDB", "NEWLINE", NULL);
return TCL_ERROR;
}
if ((src[0] == '\\') && (src[1] == '\n')) {
@@ -1085,6 +1080,7 @@ ReadOptionFile(
if (Tcl_IsSafe(interp)) {
Tcl_AppendResult(interp, "can't read options from a file in a",
" safe interpreter", NULL);
+ Tcl_SetErrorCode(interp, "TK", "OPTIONDB", "SAFE", NULL);
return TCL_ERROR;
}
@@ -1309,6 +1305,7 @@ SetupStacks(
if (tsdPtr->curLevel >= tsdPtr->numLevels) {
StackLevel *newLevels =
ckalloc(tsdPtr->numLevels * 2 * sizeof(StackLevel));
+
memcpy(newLevels, tsdPtr->levels,
tsdPtr->numLevels * sizeof(StackLevel));
ckfree(tsdPtr->levels);
diff --git a/generic/tkPack.c b/generic/tkPack.c
index b32cc23..3c3b389 100644
--- a/generic/tkPack.c
+++ b/generic/tkPack.c
@@ -152,11 +152,12 @@ void
TkPrintPadAmount(
Tcl_Interp *interp, /* The interpreter into which the result is
* written. */
- const char *switchName, /* One of "padx", "pady", "ipadx" or "ipady" */
+ const char *switchName, /* One of "padx", "pady", "ipadx" or "ipady" */
int halfSpace, /* The left or top padding amount */
int allSpace) /* The total amount of padding */
{
char buffer[60 + 2*TCL_INTEGER_SPACE];
+
if (halfSpace*2 == allSpace) {
sprintf(buffer, " -%.10s %d", switchName, halfSpace);
} else {
@@ -240,6 +241,7 @@ Tk_PackObjCmd(
if (prevPtr->masterPtr == NULL) {
Tcl_AppendResult(interp, "window \"", argv2,
"\" isn't packed", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PACK", "NOT_PACKED", NULL);
return TCL_ERROR;
}
return PackAfter(interp, prevPtr, prevPtr->masterPtr, objc-3, objv+3);
@@ -273,6 +275,7 @@ Tk_PackObjCmd(
if (packPtr->masterPtr == NULL) {
Tcl_AppendResult(interp, "window \"", argv2,
"\" isn't packed", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PACK", "NOT_PACKED", NULL);
return TCL_ERROR;
}
masterPtr = packPtr->masterPtr;
@@ -295,6 +298,7 @@ Tk_PackObjCmd(
if (argv2[0] != '.') {
Tcl_AppendResult(interp, "bad argument \"", argv2,
"\": must be name of window", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "WINDOW", NULL);
return TCL_ERROR;
}
return ConfigureSlaves(interp, tkwin, objc-2, objv+2);
@@ -335,6 +339,7 @@ Tk_PackObjCmd(
if (slavePtr->masterPtr == NULL) {
Tcl_AppendResult(interp, "window \"", argv2,
"\" isn't packed", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PACK", "NOT_PACKED", NULL);
return TCL_ERROR;
}
Tcl_AppendElement(interp, "-in");
@@ -1099,6 +1104,7 @@ PackAfter(
Tcl_AppendResult(interp, "wrong # args: window \"",
Tcl_GetString(objv[0]), "\" should be followed by options",
NULL);
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
@@ -1122,6 +1128,7 @@ PackAfter(
badWindow:
Tcl_AppendResult(interp, "can't pack ", Tcl_GetString(objv[0]),
" inside ", Tk_PathName(masterPtr->tkwin), NULL);
+ Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "HIERARCHY", NULL);
return TCL_ERROR;
}
}
@@ -1182,6 +1189,8 @@ PackAfter(
Tcl_AppendResult(interp, "wrong # args: \"", curOpt,
"\" option must be followed by screen distance",
NULL);
+ Tcl_SetErrorCode(interp, "TK", "OLDPACK", "BAD_PARAMETER",
+ NULL);
return TCL_ERROR;
}
if (TkParsePadAmount(interp, tkwin, options[index+1],
@@ -1209,6 +1218,8 @@ PackAfter(
if (optionCount < (index+2)) {
Tcl_AppendResult(interp, "wrong # args: \"frame\" ",
"option must be followed by anchor point", NULL);
+ Tcl_SetErrorCode(interp, "TK", "OLDPACK", "BAD_PARAMETER",
+ NULL);
return TCL_ERROR;
}
if (Tk_GetAnchorFromObj(interp, options[index+1],
@@ -1220,6 +1231,8 @@ PackAfter(
Tcl_AppendResult(interp, "bad option \"", curOpt,
"\": should be top, bottom, left, right, expand, ",
"fill, fillx, filly, padx, pady, or frame", NULL);
+ Tcl_SetErrorCode(interp, "TK", "OLDPACK", "BAD_PARAMETER",
+ NULL);
return TCL_ERROR;
}
}
@@ -1536,6 +1549,7 @@ ConfigureSlaves(
if (Tk_TopWinHierarchy(slave)) {
Tcl_AppendResult(interp, "can't pack \"", Tcl_GetString(objv[j]),
"\": it's a top-level window", NULL);
+ Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "TOPLEVEL", NULL);
return TCL_ERROR;
}
slavePtr = GetPacker(slave);
@@ -1561,6 +1575,7 @@ ConfigureSlaves(
Tcl_AppendResult(interp, "extra option \"",
Tcl_GetString(objv[i]),
"\" (option with no value?)", NULL);
+ Tcl_SetErrorCode(interp, "TK", "PACK", "BAD_PARAMETER", NULL);
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[i], optionStrings, "option",
@@ -1581,6 +1596,8 @@ ConfigureSlaves(
Tcl_AppendResult(interp, "window \"",
Tcl_GetString(objv[i+1]), "\" isn't packed",
NULL);
+ Tcl_SetErrorCode(interp, "TK", "PACK", "NOT_PACKED",
+ NULL);
return TCL_ERROR;
}
masterPtr = prevPtr->masterPtr;
@@ -1637,6 +1654,7 @@ ConfigureSlaves(
} else {
Tcl_AppendResult(interp, "bad fill style \"", string,
"\": must be none, x, y, or both", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "FILL", NULL);
return TCL_ERROR;
}
break;
@@ -1664,6 +1682,7 @@ ConfigureSlaves(
Tcl_AppendResult(interp, "bad ipadx value \"",
Tcl_GetString(objv[i+1]),
"\": must be positive screen distance", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "INT_PAD", NULL);
return TCL_ERROR;
}
slavePtr->iPadX = tmp * 2;
@@ -1676,6 +1695,7 @@ ConfigureSlaves(
Tcl_AppendResult(interp, "bad ipady value \"",
Tcl_GetString(objv[i+1]),
"\": must be positive screen distance", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "INT_PAD", NULL);
return TCL_ERROR;
}
slavePtr->iPadY = tmp * 2;
@@ -1754,12 +1774,14 @@ ConfigureSlaves(
if (Tk_TopWinHierarchy(ancestor)) {
Tcl_AppendResult(interp, "can't pack ", Tcl_GetString(objv[j]),
" inside ", Tk_PathName(masterPtr->tkwin), NULL);
+ Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "HIERARCHY", NULL);
return TCL_ERROR;
}
}
if (slave == masterPtr->tkwin) {
Tcl_AppendResult(interp, "can't pack ", Tcl_GetString(objv[j]),
" inside itself", NULL);
+ Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "SELF", NULL);
return TCL_ERROR;
}
diff --git a/generic/tkPlace.c b/generic/tkPlace.c
index 22072ce..a0d3562 100644
--- a/generic/tkPlace.c
+++ b/generic/tkPlace.c
@@ -621,6 +621,7 @@ ConfigureSlave(
if (Tk_TopWinHierarchy(tkwin)) {
Tcl_AppendResult(interp, "can't use placer on top-level window \"",
Tk_PathName(tkwin), "\"; use wm command instead", NULL);
+ Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "TOPLEVEL", NULL);
return TCL_ERROR;
}
@@ -681,6 +682,7 @@ ConfigureSlave(
Tcl_AppendResult(interp, "can't place ",
Tk_PathName(slavePtr->tkwin), " relative to ",
Tk_PathName(tkwin), NULL);
+ Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "HIERARCHY", NULL);
goto error;
}
}
@@ -688,6 +690,7 @@ ConfigureSlave(
Tcl_AppendResult(interp, "can't place ",
Tk_PathName(slavePtr->tkwin), " relative to itself",
NULL);
+ Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "LOOP", NULL);
goto error;
}
if ((slavePtr->masterPtr != NULL)
diff --git a/generic/tkRectOval.c b/generic/tkRectOval.c
index 630737c..c41387c 100644
--- a/generic/tkRectOval.c
+++ b/generic/tkRectOval.c
@@ -348,10 +348,8 @@ RectOvalCoords(
*/
if (objc != 4) {
- char buf[64 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "wrong # coordinates: expected 0 or 4, got %d", objc);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "wrong # coordinates: expected 0 or 4, got %d", objc));
return TCL_ERROR;
}
diff --git a/generic/tkStubInit.c b/generic/tkStubInit.c
index 271243e..b1cdd53 100644
--- a/generic/tkStubInit.c
+++ b/generic/tkStubInit.c
@@ -55,7 +55,7 @@ TkpSync(Display *display)
void
TkCreateXEventSource(void)
{
- TkWinXInit(Tk_GetHINSTANCE());
+ TkWinXInit(Tk_GetHINSTANCE());
}
# define TkUnixContainerId 0
@@ -105,7 +105,7 @@ TkpPrintWindowId(
* the hex representation of a pointer. */
Window window) /* Window to be printed into buffer. */
{
- sprintf(buf, "%#08lx", (unsigned long) (window));
+ sprintf(buf, "%#08lx", (unsigned long) (window));
}
int
diff --git a/generic/tkStyle.c b/generic/tkStyle.c
index 76291fa..965230e 100644
--- a/generic/tkStyle.c
+++ b/generic/tkStyle.c
@@ -1358,6 +1358,7 @@ Tk_GetStyle(
if (interp != NULL) {
Tcl_AppendResult(interp, "style \"", name, "\" doesn't exist",
NULL);
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "STYLE", name, NULL);
}
return (Tk_Style) NULL;
}
diff --git a/generic/tkUtil.c b/generic/tkUtil.c
index 5282708..b0ea2ea 100644
--- a/generic/tkUtil.c
+++ b/generic/tkUtil.c
@@ -96,6 +96,7 @@ TkStateParseProc(
Tcl_AppendResult(interp, ",", NULL);
}
Tcl_AppendResult(interp, " or disabled", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "STATE", NULL);
*statePtr = TK_STATE_NORMAL;
return TCL_ERROR;
}
@@ -197,6 +198,7 @@ TkOrientParseProc(
}
Tcl_AppendResult(interp, "bad orientation \"", value,
"\": must be vertical or horizontal", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "ORIENTATION", NULL);
*orientPtr = 0;
return TCL_ERROR;
}
@@ -385,6 +387,7 @@ TkOffsetParseProc(
Tcl_AppendResult(interp, ", <index>", NULL);
}
Tcl_AppendResult(interp, ", n, ne, e, se, s, sw, w, nw, or center", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "OFFSET", NULL);
return TCL_ERROR;
}
@@ -482,6 +485,7 @@ TkPixelParseProc(
if ((result == TCL_OK) && (clientData == NULL) && (*doublePtr < 0.0)) {
Tcl_AppendResult(interp, "bad screen distance \"", value, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "PIXELS", NULL);
return TCL_ERROR;
}
return result;
@@ -646,6 +650,7 @@ Tk_GetScrollInfo(
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" ", argv[1], " moveto fraction\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TK_SCROLL_ERROR;
}
if (Tcl_GetDouble(interp, argv[3], dblPtr) != TCL_OK) {
@@ -657,6 +662,7 @@ Tk_GetScrollInfo(
if (argc != 5) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" ", argv[1], " scroll number units|pages\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TK_SCROLL_ERROR;
}
if (Tcl_GetInt(interp, argv[3], intPtr) != TCL_OK) {
@@ -672,10 +678,13 @@ Tk_GetScrollInfo(
Tcl_AppendResult(interp, "bad argument \"", argv[4],
"\": must be units or pages", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "SCROLL_UNITS", NULL);
return TK_SCROLL_ERROR;
}
Tcl_AppendResult(interp, "unknown option \"", argv[2],
"\": must be moveto or scroll", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", argv[2],
+ NULL);
return TK_SCROLL_ERROR;
}
@@ -746,10 +755,12 @@ Tk_GetScrollInfoObj(
Tcl_AppendResult(interp, "bad argument \"", arg,
"\": must be units or pages", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "SCROLL_UNITS", NULL);
return TK_SCROLL_ERROR;
}
Tcl_AppendResult(interp, "unknown option \"", arg,
"\": must be moveto or scroll", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", arg, NULL);
return TK_SCROLL_ERROR;
}
@@ -916,6 +927,7 @@ TkFindStateNum(
mPtr = mapPtr;
Tcl_AppendResult(interp, "bad ", option, " value \"", strKey,
"\": must be ", mPtr->strKey, NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", option, NULL);
for (mPtr++; mPtr->strKey != NULL; mPtr++) {
Tcl_AppendResult(interp,
((mPtr[1].strKey != NULL) ? ", " : ", or "),
@@ -972,6 +984,8 @@ TkFindStateNumObj(
mPtr = mapPtr;
Tcl_AppendResult(interp, "bad ", Tcl_GetString(optionPtr),
" value \"", key, "\": must be ", mPtr->strKey, NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", Tcl_GetString(optionPtr),
+ NULL);
for (mPtr++; mPtr->strKey != NULL; mPtr++) {
Tcl_AppendResult(interp,
((mPtr[1].strKey != NULL) ? ", " : ", or "),
diff --git a/generic/tkVisual.c b/generic/tkVisual.c
index 3602088..b19e78c 100644
--- a/generic/tkVisual.c
+++ b/generic/tkVisual.c
@@ -176,6 +176,7 @@ Tk_GetVisual(
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "bad X identifier for visual: \"",
string, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "VISUALID", NULL);
return NULL;
}
template.visualid = visualId;
@@ -204,6 +205,7 @@ Tk_GetVisual(
if (template.class == -1) {
Tcl_AppendResult(interp, "unknown or ambiguous visual name \"",
string, "\": class must be ", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "VISUAL", NULL);
for (dictPtr = visualNames; dictPtr->name != NULL; dictPtr++) {
Tcl_AppendResult(interp, dictPtr->name, ", ", NULL);
}
@@ -239,6 +241,7 @@ Tk_GetVisual(
if (visInfoList == NULL) {
Tcl_SetResult(interp, "couldn't find an appropriate visual",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "VISUAL", "INAPPROPRIATE", NULL);
return NULL;
}
@@ -405,11 +408,13 @@ Tk_GetColormap(
if (Tk_Screen(other) != Tk_Screen(tkwin)) {
Tcl_AppendResult(interp, "can't use colormap for ", string,
": not on same screen", NULL);
+ Tcl_SetErrorCode(interp, "TK", "COLORMAP", "SCREEN", NULL);
return None;
}
if (Tk_Visual(other) != Tk_Visual(tkwin)) {
Tcl_AppendResult(interp, "can't use colormap for ", string,
": incompatible visuals", NULL);
+ Tcl_SetErrorCode(interp, "TK", "COLORMAP", "INCOMPATIBLE", NULL);
return None;
}
colormap = Tk_Colormap(other);
diff --git a/generic/tkWindow.c b/generic/tkWindow.c
index b04b95f..27fba69 100644
--- a/generic/tkWindow.c
+++ b/generic/tkWindow.c
@@ -103,8 +103,9 @@ static const XSetWindowAttributes defAtts= {
typedef int (TkInitProc)(Tcl_Interp *interp, ClientData clientData);
typedef struct {
- const char *name; /* Name of command. */
- Tcl_ObjCmdProc *objProc; /* Command's object- (or string-) based function, or initProc. */
+ const char *name; /* Name of command. */
+ Tcl_ObjCmdProc *objProc; /* Command's object- (or string-) based
+ * function, or initProc. */
int flags;
} TkCmd;
@@ -153,7 +154,8 @@ static const TkCmd commands[] = {
{"panedwindow", Tk_PanedWindowObjCmd, ISSAFE},
{"radiobutton", Tk_RadiobuttonObjCmd, ISSAFE},
{"scale", Tk_ScaleObjCmd, ISSAFE},
- {"scrollbar", (Tcl_ObjCmdProc *) Tk_ScrollbarCmd, NOOBJPROC|PASSMAINWINDOW|ISSAFE},
+ {"scrollbar", (Tcl_ObjCmdProc *) Tk_ScrollbarCmd,
+ NOOBJPROC|PASSMAINWINDOW|ISSAFE},
{"spinbox", Tk_SpinboxObjCmd, ISSAFE},
{"text", Tk_TextObjCmd, PASSMAINWINDOW|ISSAFE},
{"toplevel", Tk_ToplevelObjCmd, 0},
@@ -175,7 +177,8 @@ static const TkCmd commands[] = {
{"::tk::panedwindow",Tk_PanedWindowObjCmd, ISSAFE},
{"::tk::radiobutton",Tk_RadiobuttonObjCmd, ISSAFE},
{"::tk::scale", Tk_ScaleObjCmd, ISSAFE},
- {"::tk::scrollbar", (Tcl_ObjCmdProc *) Tk_ScrollbarCmd, NOOBJPROC|PASSMAINWINDOW|ISSAFE},
+ {"::tk::scrollbar", (Tcl_ObjCmdProc *) Tk_ScrollbarCmd,
+ NOOBJPROC|PASSMAINWINDOW|ISSAFE},
{"::tk::spinbox", Tk_SpinboxObjCmd, ISSAFE},
{"::tk::text", Tk_TextObjCmd, PASSMAINWINDOW|ISSAFE},
{"::tk::toplevel", Tk_ToplevelObjCmd, 0},
@@ -197,7 +200,7 @@ static const TkCmd commands[] = {
* Misc.
*/
-#if defined(MAC_OSX_TK)
+#ifdef MAC_OSX_TK
{"::tk::unsupported::MacWindowStyle",
TkUnsupported1ObjCmd, PASSMAINWINDOW|ISSAFE},
#endif
@@ -290,6 +293,7 @@ TkCloseDisplay(
if (dispPtr->errorPtr != NULL) {
TkErrorHandler *errorPtr;
+
for (errorPtr = dispPtr->errorPtr;
errorPtr != NULL;
errorPtr = dispPtr->errorPtr) {
@@ -470,6 +474,7 @@ GetScreen(
Tcl_SetResult(interp,
"no display name and no $DISPLAY environment variable",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "NO_DISPLAY", NULL);
return NULL;
}
length = strlen(screenName);
@@ -500,6 +505,7 @@ GetScreen(
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't connect to display \"",
screenName, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "DISPLAY", "CONNECTION", NULL);
return NULL;
}
dispPtr->nextPtr = tsdPtr->displayList; /* TkGetDisplayList(); */
@@ -531,10 +537,9 @@ GetScreen(
}
}
if (screenId >= ScreenCount(dispPtr->display)) {
- char buf[32 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "bad screen number \"%d\"", screenId);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad screen number \"%d\"", screenId));
+ Tcl_SetErrorCode(interp, "TK", "DISPLAY", "SCREEN_NUMBER", NULL);
return NULL;
}
*screenPtr = screenId;
@@ -774,12 +779,6 @@ NameWindow(
}
/*
- * For non-anonymous windows, set up the window name.
- */
-
- winPtr->nameUid = Tk_GetUid(name);
-
- /*
* Don't permit names that start with an upper-case letter: this will just
* cause confusion with class names in the option database.
*/
@@ -788,10 +787,17 @@ NameWindow(
Tcl_AppendResult(interp,
"window name starts with an upper-case letter: \"",
name, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "WINDOW", "NOTCLASS", NULL);
return TCL_ERROR;
}
/*
+ * For non-anonymous windows, set up the window name.
+ */
+
+ winPtr->nameUid = Tk_GetUid(name);
+
+ /*
* To permit names of arbitrary length, must be prepared to malloc a
* buffer to hold the new path name. To run fast in the common case where
* names are short, use a fixed-size buffer on the stack.
@@ -820,6 +826,7 @@ NameWindow(
if (!isNew) {
Tcl_AppendResult(interp, "window name \"", name,
"\" already exists in parent", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "WINDOW", "EXISTS", NULL);
return TCL_ERROR;
}
Tcl_SetHashValue(hPtr, winPtr);
@@ -964,7 +971,7 @@ TkCreateMainWindow(
clientData = NULL;
}
if (cmdPtr->flags & USEINITPROC) {
- ((TkInitProc *)cmdPtr->objProc)(interp, clientData);
+ ((TkInitProc *) cmdPtr->objProc)(interp, clientData);
} else if (cmdPtr->flags & NOOBJPROC) {
Tcl_CreateCommand(interp, cmdPtr->name,
(Tcl_CmdProc *) cmdPtr->objProc, clientData, NULL);
@@ -972,10 +979,8 @@ TkCreateMainWindow(
Tcl_CreateObjCommand(interp, cmdPtr->name, cmdPtr->objProc,
clientData, NULL);
}
- if (isSafe) {
- if (!(cmdPtr->flags & ISSAFE)) {
- Tcl_HideCommand(interp, cmdPtr->name, cmdPtr->name);
- }
+ if (isSafe && !(cmdPtr->flags & ISSAFE)) {
+ Tcl_HideCommand(interp, cmdPtr->name, cmdPtr->name);
}
}
@@ -1034,11 +1039,13 @@ Tk_CreateWindow(
if (parentPtr->flags & TK_ALREADY_DEAD) {
Tcl_AppendResult(interp,
"can't create window: parent has been destroyed", NULL);
+ Tcl_SetErrorCode(interp, "TK", "CREATE", "DEAD_PARENT", NULL);
return NULL;
} else if (parentPtr->flags & TK_CONTAINER) {
Tcl_AppendResult(interp,
"can't create window: its parent has -container = yes",
NULL);
+ Tcl_SetErrorCode(interp, "TK", "CREATE", "CONTAINER", NULL);
return NULL;
} else if (screenName == NULL) {
TkWindow *winPtr = TkAllocWindow(parentPtr->dispPtr,
@@ -1096,11 +1103,13 @@ Tk_CreateAnonymousWindow(
if (parentPtr->flags & TK_ALREADY_DEAD) {
Tcl_AppendResult(interp,
"can't create window: parent has been destroyed", NULL);
+ Tcl_SetErrorCode(interp, "TK", "CREATE", "DEAD_PARENT", NULL);
return NULL;
} else if (parentPtr->flags & TK_CONTAINER) {
Tcl_AppendResult(interp,
"can't create window: its parent has -container = yes",
NULL);
+ Tcl_SetErrorCode(interp, "TK", "CREATE", "CONTAINER", NULL);
return NULL;
} else if (screenName == NULL) {
TkWindow *winPtr = TkAllocWindow(parentPtr->dispPtr,
@@ -1178,6 +1187,7 @@ Tk_CreateWindowFromPath(
if (p == NULL) {
Tcl_AppendResult(interp, "bad window path name \"", pathName,
"\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "WINDOWPATH", NULL);
return NULL;
}
numChars = (int) (p-pathName);
@@ -1208,11 +1218,13 @@ Tk_CreateWindowFromPath(
if (((TkWindow *) parent)->flags & TK_ALREADY_DEAD) {
Tcl_AppendResult(interp,
"can't create window: parent has been destroyed", NULL);
+ Tcl_SetErrorCode(interp, "TK", "CREATE", "DEAD_PARENT", NULL);
return NULL;
}
if (((TkWindow *) parent)->flags & TK_CONTAINER) {
Tcl_AppendResult(interp,
"can't create window: its parent has -container = yes", NULL);
+ Tcl_SetErrorCode(interp, "TK", "CREATE", "CONTAINER", NULL);
return NULL;
}
@@ -1354,8 +1366,8 @@ Tk_DestroyWindow(
}
while (winPtr->childList != NULL) {
- TkWindow *childPtr;
- childPtr = winPtr->childList;
+ TkWindow *childPtr = winPtr->childList;
+
childPtr->flags |= TK_DONT_DESTROY_WINDOW;
Tk_DestroyWindow((Tk_Window) childPtr);
if (winPtr->childList == childPtr) {
@@ -1382,8 +1394,8 @@ Tk_DestroyWindow(
* deleted, in which case TkpGetOtherWindow will return NULL.
*/
- TkWindow *childPtr;
- childPtr = TkpGetOtherWindow(winPtr);
+ TkWindow *childPtr = TkpGetOtherWindow(winPtr);
+
if (childPtr != NULL) {
childPtr->flags |= TK_DONT_DESTROY_WINDOW;
Tk_DestroyWindow((Tk_Window) childPtr);
@@ -1751,6 +1763,7 @@ Tk_MakeWindowExist(
if ((winPtr2->window != None)
&& !(winPtr2->flags & (TK_TOP_HIERARCHY|TK_REPARENTED))) {
XWindowChanges changes;
+
changes.sibling = winPtr2->window;
changes.stack_mode = Below;
XConfigureWindow(winPtr->display, winPtr->window,
@@ -2328,7 +2341,8 @@ Tk_NameToWindow(
*/
if (interp != NULL) {
- Tcl_AppendResult(interp, "NULL main window", NULL);
+ Tcl_SetResult(interp, "NULL main window", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "NO_MAIN_WINDOW", NULL);
}
return NULL;
}
@@ -2339,6 +2353,7 @@ Tk_NameToWindow(
if (interp != NULL) {
Tcl_AppendResult(interp, "bad window path name \"",
pathName, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "WINDOWNAME", NULL);
}
return NULL;
}
@@ -2591,9 +2606,8 @@ Tk_RestackWindow(
if (winPtr->window != None) {
XWindowChanges changes;
- unsigned int mask;
+ unsigned int mask = CWStackMode;
- mask = CWStackMode;
changes.stack_mode = Above;
for (otherPtr = winPtr->nextPtr; otherPtr != NULL;
otherPtr = otherPtr->nextPtr) {
@@ -2653,6 +2667,7 @@ Tk_MainWindow(
}
}
Tcl_SetResult(interp, "this isn't a Tk application", TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TK", "NO_MAIN_WINDOW", NULL);
return NULL;
}
@@ -2840,44 +2855,47 @@ static HMODULE tkcygwindll = NULL;
/*
* Run Tk_MainEx from libtk8.?.dll
*
- * This function is only ever called from wish8.4.exe, the cygwin
- * port of Tcl. This means that the system encoding is utf-8,
- * so we don't have to do any encoding conversions.
+ * This function is only ever called from wish8.4.exe, the cygwin port of Tcl.
+ * This means that the system encoding is utf-8, so we don't have to do any
+ * encoding conversions.
*/
+
int
-TkCygwinMainEx(argc, argv, appInitProc, interp)
- int argc; /* Number of arguments. */
- char **argv; /* Array of argument strings. */
- Tcl_AppInitProc *appInitProc; /* Application-specific initialization
- * procedure to call after most
- * initialization but before starting
- * to execute commands. */
- Tcl_Interp *interp;
+TkCygwinMainEx(
+ int argc, /* Number of arguments. */
+ char **argv, /* Array of argument strings. */
+ Tcl_AppInitProc *appInitProc,
+ /* Application-specific initialization
+ * procedure to call after most initialization
+ * but before starting to execute commands. */
+ Tcl_Interp *interp)
{
TCHAR name[MAX_PATH];
int len;
- void (*sym)(int, char **, Tcl_AppInitProc *, Tcl_Interp *);
+ void (*tkmainex)(int, char **, Tcl_AppInitProc *, Tcl_Interp *);
/* construct "<path>/libtk8.?.dll", from "<path>/tk8?.dll" */
- len = GetModuleFileNameW(Tk_GetHINSTANCE(), name, MAX_PATH);
- name[len-2] = TEXT('.');
- name[len-1] = name[len-5];
- _tcscpy(name+len, TEXT(".dll"));
- memcpy(name+len-8, TEXT("libtk8"), 6 * sizeof(TCHAR));
-
- tkcygwindll = LoadLibrary(name);
- if (!tkcygwindll) {
- /* dll is not present */
- return 0;
- }
- sym = (void (*)(int, char **, Tcl_AppInitProc *, Tcl_Interp *)) GetProcAddress(tkcygwindll, "Tk_MainEx");
- if (!sym) {
- return 0;
- }
- sym(argc, argv, appInitProc, interp);
+ len = GetModuleFileNameW(Tk_GetHINSTANCE(), name, MAX_PATH);
+ name[len-2] = TEXT('.');
+ name[len-1] = name[len-5];
+ _tcscpy(name+len, TEXT(".dll"));
+ memcpy(name+len-8, TEXT("libtk8"), 6 * sizeof(TCHAR));
+
+ tkcygwindll = LoadLibrary(name);
+ if (!tkcygwindll) {
+ /* dll is not present */
+ return 0;
+ }
+ tkmainex = (void (*)(int, char **, Tcl_AppInitProc *, Tcl_Interp *))
+ GetProcAddress(tkcygwindll, "Tk_MainEx");
+ if (!tkmainex) {
+ return 0;
+ }
+ tkmainex(argc, argv, appInitProc, interp);
return 1;
}
-#endif
+#endif /* __WIN32__ && !__WIN64__ */
+
/*
*----------------------------------------------------------------------
*
@@ -2907,14 +2925,14 @@ Tk_Init(
{
#if defined(__WIN32__) && !defined(__WIN64__)
if (tkcygwindll) {
- int (*sym)(Tcl_Interp *);
+ int (*tkinit)(Tcl_Interp *);
- sym = (int (*)(Tcl_Interp *)) GetProcAddress(tkcygwindll, "Tk_Init");
- if (sym) {
- return sym(interp);
+ tkinit = (int(*)(Tcl_Interp *)) GetProcAddress(tkcygwindll,"Tk_Init");
+ if (tkinit) {
+ return tkinit(interp);
}
}
-#endif
+#endif /* __WIN32__ && !__WIN64__ */
return Initialize(interp);
}
@@ -2980,14 +2998,15 @@ Tk_SafeInit(
#if defined(__WIN32__) && !defined(__WIN64__)
if (tkcygwindll) {
- int (*sym)(Tcl_Interp *);
+ int (*tksafeinit)(Tcl_Interp *);
- sym = (int (*)(Tcl_Interp *)) GetProcAddress(tkcygwindll, "Tk_SafeInit");
- if (sym) {
- return sym(interp);
+ tksafeinit = (int (*)(Tcl_Interp *))
+ GetProcAddress(tkcygwindll, "Tk_SafeInit");
+ if (tksafeinit) {
+ return tksafeinit(interp);
}
}
-#endif
+#endif /* __WIN32__ && !__WIN64__ */
return Initialize(interp);
}
@@ -2998,7 +3017,8 @@ MODULE_SCOPE const TkStubs tkStubs;
*
* Initialize --
*
- * ???TODO???
+ * The core of the initialization code for Tk, called from Tk_Init and
+ * Tk_SafeInit.
*
* Results:
* A standard Tcl result. Also leaves an error message in the interp's
@@ -3083,6 +3103,7 @@ Initialize(
master = Tcl_GetMaster(master);
if (master == NULL) {
Tcl_AppendResult(interp, "NULL master", NULL);
+ Tcl_SetErrorCode(interp, "TK", "SAFE", "FAILED", NULL);
code = TCL_ERROR;
goto done;
}
@@ -3099,6 +3120,7 @@ Initialize(
code = Tcl_GetInterpPath(master, interp);
if (code != TCL_OK) {
Tcl_AppendResult(interp, "error in Tcl_GetInterpPath", NULL);
+ Tcl_SetErrorCode(interp, "TK", "SAFE", "FAILED", NULL);
goto done;
}
@@ -3125,6 +3147,7 @@ Initialize(
Tcl_DStringFree(&ds);
Tcl_AppendResult(interp,
"not allowed to start Tk by master's safe::TkInit", NULL);
+ Tcl_SetErrorCode(interp, "TK", "SAFE", "FAILED", NULL);
goto done;
}
Tcl_DStringFree(&ds);
@@ -3389,6 +3412,7 @@ Tk_PkgInitStubsCheck(
}
return actualVersion;
}
+
/*
* Local Variables:
* mode: c
diff --git a/macosx/tkMacOSXWindowEvent.c b/macosx/tkMacOSXWindowEvent.c
index 722ac9d..48ac5b2 100644
--- a/macosx/tkMacOSXWindowEvent.c
+++ b/macosx/tkMacOSXWindowEvent.c
@@ -704,10 +704,9 @@ TkWmProtocolEventProc(
Tcl_Preserve(interp);
result = Tcl_GlobalEval(interp, protPtr->command);
if (result != TCL_OK) {
- Tcl_AddErrorInfo(interp, "\n (command for \"");
- Tcl_AddErrorInfo(interp,
- Tk_GetAtomName((Tk_Window) winPtr, protocol));
- Tcl_AddErrorInfo(interp, "\" window manager protocol)");
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (command for \"%s\" window manager protocol)",
+ Tk_GetAtomName((Tk_Window) winPtr, protocol)));
Tcl_BackgroundError(interp);
}
Tcl_Release(interp);
diff --git a/macosx/tkMacOSXWm.c b/macosx/tkMacOSXWm.c
index f2cb572..44b88f2 100644
--- a/macosx/tkMacOSXWm.c
+++ b/macosx/tkMacOSXWm.c
@@ -51,7 +51,6 @@
| tkCanJoinAllSpacesAttribute | tkMoveToActiveSpaceAttribute \
| tkNonactivatingPanelAttribute | tkHUDWindowAttribute)
-
/*Objects for use in setting background color and opacity of window.*/
NSColor *colorName = NULL;
NSString *opaqueTag = NULL;
@@ -479,7 +478,6 @@ FrontWindowAtPoint(
}
return (win ? TkMacOSXGetTkWindow(win) : NULL);
}
-
/*
*----------------------------------------------------------------------
@@ -561,7 +559,6 @@ TkWmNewWindow(
UpdateVRootGeometry(wmPtr);
-
/*
* Tk must monitor structure events for top-level windows, in order to
* detect size and position changes caused by window managers.
@@ -753,9 +750,8 @@ TkWmDeadWindow(
wmPtr2->hints.flags &= ~IconWindowHint;
}
while (wmPtr->protPtr != NULL) {
- ProtocolHandler *protPtr;
+ ProtocolHandler *protPtr = wmPtr->protPtr;
- protPtr = wmPtr->protPtr;
wmPtr->protPtr = protPtr->nextPtr;
Tcl_EventuallyFree(protPtr, TCL_DYNAMIC);
}
@@ -782,7 +778,7 @@ TkWmDeadWindow(
[window close];
TkMacOSXUnregisterMacWindow(window);
if (winPtr->window) {
- ((MacDrawable *)winPtr->window)->view = nil;
+ ((MacDrawable *) winPtr->window)->view = nil;
}
TkMacOSXMakeCollectableAndRelease(wmPtr->window);
}
@@ -875,13 +871,13 @@ Tk_WmObjCmd(
argv1 = Tcl_GetStringFromObj(objv[1], &length);
if ((argv1[0] == 't') && (strncmp(argv1, "tracing", length) == 0)
- && (length >= 3)) {
+ && (length >= 3)) {
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 2, objv, "?boolean?");
return TCL_ERROR;
}
if (objc == 2) {
- Tcl_SetResult(interp, ((wmTracing) ? "on" : "off"), TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(wmTracing));
return TCL_OK;
}
return Tcl_GetBooleanFromObj(interp, objv[2], &wmTracing);
@@ -1013,12 +1009,13 @@ WmAspectCmd(
}
if (objc == 3) {
if (wmPtr->sizeHintsFlags & PAspect) {
- char buf[TCL_INTEGER_SPACE * 4];
+ Tcl_Obj *results[4];
- sprintf(buf, "%d %d %d %d", wmPtr->minAspect.x,
- wmPtr->minAspect.y, wmPtr->maxAspect.x,
- wmPtr->maxAspect.y);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ results[0] = Tcl_NewIntObj(wmPtr->minAspect.x);
+ results[1] = Tcl_NewIntObj(wmPtr->minAspect.y);
+ results[2] = Tcl_NewIntObj(wmPtr->maxAspect.x);
+ results[3] = Tcl_NewIntObj(wmPtr->maxAspect.y);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(4, results));
}
return TCL_OK;
}
@@ -1276,9 +1273,9 @@ WmAttributesCmd(
Tcl_Obj *result = Tcl_NewListObj(0,0);
for (attribute = 0; attribute < _WMATT_LAST_ATTRIBUTE; ++attribute) {
- Tcl_ListObjAppendElement(interp, result,
+ Tcl_ListObjAppendElement(NULL, result,
Tcl_NewStringObj(WmAttributeNames[attribute], -1));
- Tcl_ListObjAppendElement(interp, result,
+ Tcl_ListObjAppendElement(NULL, result,
WmGetAttribute(winPtr, macWindow, attribute));
}
Tcl_SetObjResult(interp, result);
@@ -1293,7 +1290,7 @@ WmAttributesCmd(
for (i = 3; i < objc; i += 2) {
if (Tcl_GetIndexFromObj(interp, objv[i], WmAttributeNames,
- "attribute", 0, &attribute) != TCL_OK) {
+ "attribute", 0, &attribute) != TCL_OK) {
return TCL_ERROR;
}
if (WmSetAttribute(winPtr, macWindow, interp, attribute, objv[i+1])
@@ -1402,7 +1399,7 @@ WmColormapwindowsCmd(
Tk_MakeWindowExist((Tk_Window) winPtr);
for (i = 0; i < wmPtr->cmapCount; i++) {
if ((i == (wmPtr->cmapCount-1))
- && (wmPtr->flags & WM_ADDED_TOPLEVEL_COLORMAP)) {
+ && (wmPtr->flags & WM_ADDED_TOPLEVEL_COLORMAP)) {
break;
}
Tcl_AppendElement(interp, wmPtr->cmapList[i]->pathName);
@@ -1410,7 +1407,7 @@ WmColormapwindowsCmd(
return TCL_OK;
}
if (Tcl_ListObjGetElements(interp, objv[3], &windowObjc, &windowObjv)
- != TCL_OK) {
+ != TCL_OK) {
return TCL_ERROR;
}
cmapList = ckalloc((windowObjc+1) * sizeof(TkWindow*));
@@ -1486,7 +1483,7 @@ WmCommandCmd(
}
if (objc == 3) {
if (wmPtr->cmdArgv != NULL) {
- argv3 = Tcl_Merge(wmPtr->cmdArgc, wmPtr->cmdArgv);
+ argv3 = Tcl_Merge(wmPtr->cmdArgc, wmPtr->cmdArgv);
Tcl_SetResult(interp, argv3, TCL_VOLATILE);
ckfree(argv3);
}
@@ -1543,13 +1540,15 @@ WmDeiconifyCmd(
return TCL_ERROR;
}
if (wmPtr->iconFor != NULL) {
- Tcl_AppendResult(interp, "can't deiconify ", Tcl_GetString(objv[2]),
- ": it is an icon for ", Tk_PathName(wmPtr->iconFor), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't deiconify %s: it is an icon for %s",
+ Tcl_GetString(objv[2]), Tk_PathName(wmPtr->iconFor)));
return TCL_ERROR;
}
if (winPtr->flags & TK_EMBEDDED) {
- Tcl_AppendResult(interp, "can't deiconify ", winPtr->pathName,
- ": it is an embedded window", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't deiconify %s: it is an embedded window",
+ winPtr->pathName));
return TCL_ERROR;
}
TkpWmSetState(winPtr, TkMacOSXIsWindowZoomed(winPtr) ?
@@ -1687,7 +1686,6 @@ WmFrameCmd(
{
register WmInfo *wmPtr = winPtr->wmInfoPtr;
Window window;
- char buf[TCL_INTEGER_SPACE];
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "window");
@@ -1697,8 +1695,7 @@ WmFrameCmd(
if (window == None) {
window = Tk_WindowId((Tk_Window) winPtr);
}
- sprintf(buf, "0x%x", (unsigned) window);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("0x%x", (unsigned) window));
return TCL_OK;
}
@@ -1750,9 +1747,8 @@ WmGeometryCmd(
width = winPtr->changes.width;
height = winPtr->changes.height;
}
- sprintf(buf, "%dx%d%c%d%c%d",
- width, height, xSign, wmPtr->x, ySign, wmPtr->y);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("%dx%d%c%d%c%d",
+ width, height, xSign, wmPtr->x, ySign, wmPtr->y));
return TCL_OK;
}
argv3 = Tcl_GetString(objv[3]);
@@ -1800,12 +1796,13 @@ WmGridCmd(
}
if (objc == 3) {
if (wmPtr->sizeHintsFlags & PBaseSize) {
- char buf[TCL_INTEGER_SPACE * 4];
+ Tcl_Obj *results[4];
- sprintf(buf, "%d %d %d %d", wmPtr->reqGridWidth,
- wmPtr->reqGridHeight, wmPtr->widthInc,
- wmPtr->heightInc);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ results[0] = Tcl_NewIntObj(wmPtr->reqGridWidth);
+ results[1] = Tcl_NewIntObj(wmPtr->reqGridHeight);
+ results[2] = Tcl_NewIntObj(wmPtr->widthInc);
+ results[3] = Tcl_NewIntObj(wmPtr->heightInc);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(4, results));
}
return TCL_OK;
}
@@ -1954,8 +1951,9 @@ WmIconbitmapCmd(
}
if (objc == 3) {
if (wmPtr->hints.flags & IconPixmapHint) {
- Tcl_SetResult(interp, (char*)Tk_NameOfBitmap(winPtr->display,
- wmPtr->hints.icon_pixmap), TCL_STATIC);
+ Tcl_SetResult(interp, (char *)
+ Tk_NameOfBitmap(winPtr->display,wmPtr->hints.icon_pixmap),
+ TCL_STATIC);
}
return TCL_OK;
}
@@ -2075,8 +2073,9 @@ WmIconmaskCmd(
}
if (objc == 3) {
if (wmPtr->hints.flags & IconMaskHint) {
- Tcl_SetResult(interp, (char *) Tk_NameOfBitmap(winPtr->display,
- wmPtr->hints.icon_mask), TCL_STATIC);
+ Tcl_SetResult(interp, (char *)
+ Tk_NameOfBitmap(winPtr->display, wmPtr->hints.icon_mask),
+ TCL_STATIC);
}
return TCL_OK;
}
@@ -2249,11 +2248,11 @@ WmIconpositionCmd(
}
if (objc == 3) {
if (wmPtr->hints.flags & IconPositionHint) {
- char buf[TCL_INTEGER_SPACE * 2];
+ Tcl_Obj *results[2];
- sprintf(buf, "%d %d", wmPtr->hints.icon_x,
- wmPtr->hints.icon_y);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ results[0] = Tcl_NewIntObj(wmPtr->hints.icon_x);
+ results[1] = Tcl_NewIntObj(wmPtr->hints.icon_y);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, results));
}
return TCL_OK;
}
@@ -2450,15 +2449,16 @@ WmMaxsizeCmd(
return TCL_ERROR;
}
if (objc == 3) {
- char buf[TCL_INTEGER_SPACE * 2];
+ Tcl_Obj *results[2];
GetMaxSize(winPtr, &width, &height);
- sprintf(buf, "%d %d", width, height);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ results[0] = Tcl_NewIntObj(width);
+ results[1] = Tcl_NewIntObj(height);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, results));
return TCL_OK;
}
if ((Tcl_GetIntFromObj(interp, objv[3], &width) != TCL_OK)
- || (Tcl_GetIntFromObj(interp, objv[4], &height) != TCL_OK)) {
+ || (Tcl_GetIntFromObj(interp, objv[4], &height) != TCL_OK)) {
return TCL_ERROR;
}
wmPtr->maxWidth = width;
@@ -2501,11 +2501,12 @@ WmMinsizeCmd(
return TCL_ERROR;
}
if (objc == 3) {
- char buf[TCL_INTEGER_SPACE * 2];
+ Tcl_Obj *results[2];
GetMinSize(winPtr, &width, &height);
- sprintf(buf, "%d %d", width, height);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ results[0] = Tcl_NewIntObj(width);
+ results[1] = Tcl_NewIntObj(height);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, results));
return TCL_OK;
}
if ((Tcl_GetIntFromObj(interp, objv[3], &width) != TCL_OK)
@@ -2756,16 +2757,15 @@ WmResizableCmd(
return TCL_ERROR;
}
if (objc == 3) {
- char buf[TCL_INTEGER_SPACE * 2];
+ Tcl_Obj *results[2];
- sprintf(buf, "%d %d",
- (wmPtr->flags & WM_WIDTH_NOT_RESIZABLE) ? 0 : 1,
- (wmPtr->flags & WM_HEIGHT_NOT_RESIZABLE) ? 0 : 1);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ results[0] = Tcl_NewBooleanObj(!(wmPtr->flags & WM_WIDTH_NOT_RESIZABLE));
+ results[1] = Tcl_NewBooleanObj(!(wmPtr->flags & WM_HEIGHT_NOT_RESIZABLE));
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, results));
return TCL_OK;
}
if ((Tcl_GetBooleanFromObj(interp, objv[3], &width) != TCL_OK)
- || (Tcl_GetBooleanFromObj(interp, objv[4], &height) != TCL_OK)) {
+ || (Tcl_GetBooleanFromObj(interp, objv[4], &height) != TCL_OK)) {
return TCL_ERROR;
}
if (width) {
@@ -4981,7 +4981,6 @@ TkUnsupported1ObjCmd(
return TCL_ERROR;
}
-
/* Iterate through objc/objv to set correct background color and toggle opacity of window. */
int i;
for (i= 0; i < objc; i++) {
@@ -5186,7 +5185,6 @@ WmWinStyle(
Tcl_Panic("invalid class");
}
-
attributeList = Tcl_NewListObj(0, NULL);
attributes = wmPtr->attributes;
@@ -5259,7 +5257,6 @@ WmWinStyle(
return TCL_ERROR;
}
-
return TCL_OK;
}
@@ -6573,8 +6570,6 @@ RemapWindows(
RemapWindows(childPtr, (MacDrawable *) winPtr->window);
}
}
-
-
/*
* Local Variables:
diff --git a/unix/tkUnix.c b/unix/tkUnix.c
index 841a1b7..c6fff82 100644
--- a/unix/tkUnix.c
+++ b/unix/tkUnix.c
@@ -13,7 +13,14 @@
#include "tkInt.h"
#ifdef HAVE_XSS
-#include <X11/extensions/scrnsaver.h>
+# include <X11/extensions/scrnsaver.h>
+# ifdef __APPLE__
+/* Support for weak-linked libXss. */
+# define HaveXSSLibrary() (XScreenSaverQueryInfo != NULL)
+# else
+/* Other platforms always link libXss. */
+# define HaveXSSLibrary() (1)
+# endif
#endif
/*
@@ -26,7 +33,7 @@
* server" command.
*
* Results:
- * None.
+ * Sets the interpreter result.
*
* Side effects:
* None.
@@ -41,14 +48,11 @@ TkGetServerInfo(
Tk_Window tkwin) /* Token for window; this selects a particular
* display and server. */
{
- char buffer[8 + TCL_INTEGER_SPACE * 2];
- char buffer2[TCL_INTEGER_SPACE];
-
- sprintf(buffer, "X%dR%d ", ProtocolVersion(Tk_Display(tkwin)),
- ProtocolRevision(Tk_Display(tkwin)));
- sprintf(buffer2, " %d", VendorRelease(Tk_Display(tkwin)));
- Tcl_AppendResult(interp, buffer, ServerVendor(Tk_Display(tkwin)),
- buffer2, (char *) NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("X%dR%d %s %d",
+ ProtocolVersion(Tk_Display(tkwin)),
+ ProtocolRevision(Tk_Display(tkwin)),
+ ServerVendor(Tk_Display(tkwin)),
+ VendorRelease(Tk_Display(tkwin))));
}
/*
@@ -207,13 +211,9 @@ Tk_GetUserInactiveTime(
* on some buggy versions of XFree86.
*/
- if (
-#ifdef __APPLE__
- XScreenSaverQueryInfo != NULL && /* Support for weak-linked libXss. */
-#endif
- XScreenSaverQueryExtension(dpy, &eventBase, &errorBase) &&
- XScreenSaverQueryVersion(dpy, &major, &minor)) {
-
+ if (HaveXSSLibrary()
+ && XScreenSaverQueryExtension(dpy, &eventBase, &errorBase)
+ && XScreenSaverQueryVersion(dpy, &major, &minor)) {
XScreenSaverInfo *info = XScreenSaverAllocInfo();
if (info == NULL) {
diff --git a/unix/tkUnixSelect.c b/unix/tkUnixSelect.c
index 172d5ca..a67e75e 100644
--- a/unix/tkUnixSelect.c
+++ b/unix/tkUnixSelect.c
@@ -583,13 +583,11 @@ TkSelEventProc(
if ((type == XA_STRING) || (type == dispPtr->textAtom)
|| (type == dispPtr->compoundTextAtom)) {
Tcl_Encoding encoding;
- if (format != 8) {
- char buf[64 + TCL_INTEGER_SPACE];
- sprintf(buf,
+ if (format != 8) {
+ Tcl_SetObjResult(retrPtr->interp, Tcl_ObjPrintf(
"bad format for string selection: wanted \"8\", got \"%d\"",
- format);
- Tcl_SetResult(retrPtr->interp, buf, TCL_VOLATILE);
+ format));
retrPtr->result = TCL_ERROR;
return;
}
@@ -631,12 +629,9 @@ TkSelEventProc(
char *propData = propInfo;
if (format != 8) {
- char buf[64 + TCL_INTEGER_SPACE];
-
- sprintf(buf,
+ Tcl_SetObjResult(retrPtr->interp, Tcl_ObjPrintf(
"bad format for string selection: wanted \"8\", got \"%d\"",
- format);
- Tcl_SetResult(retrPtr->interp, buf, TCL_VOLATILE);
+ format));
retrPtr->result = TCL_ERROR;
return;
}
@@ -673,11 +668,9 @@ TkSelEventProc(
Tcl_DString ds;
if (format != 32 && format != 8) {
- char buf[64 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "bad format for selection: wanted \"32\" or "
- "\"8\", got \"%d\"", format);
- Tcl_SetResult(retrPtr->interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(retrPtr->interp, Tcl_ObjPrintf(
+ "bad format for selection: wanted \"32\" or "
+ "\"8\", got \"%d\"", format));
retrPtr->result = TCL_ERROR;
return;
}
@@ -1150,12 +1143,9 @@ SelRcvIncrProc(
Tcl_DString *dstPtr, temp;
if (format != 8) {
- char buf[64 + TCL_INTEGER_SPACE];
-
- sprintf(buf,
+ Tcl_SetObjResult(retrPtr->interp, Tcl_ObjPrintf(
"bad format for string selection: wanted \"8\", got \"%d\"",
- format);
- Tcl_SetResult(retrPtr->interp, buf, TCL_VOLATILE);
+ format));
retrPtr->result = TCL_ERROR;
goto done;
}
@@ -1257,11 +1247,9 @@ SelRcvIncrProc(
Tcl_DString ds;
if (format != 32 && format != 8) {
- char buf[64 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "bad format for selection: wanted \"32\" or "
- "\"8\", got \"%d\"", format);
- Tcl_SetResult(retrPtr->interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(retrPtr->interp, Tcl_ObjPrintf(
+ "bad format for selection: wanted \"32\" or "
+ "\"8\", got \"%d\"", format));
retrPtr->result = TCL_ERROR;
goto done;
}
diff --git a/unix/tkUnixWm.c b/unix/tkUnixWm.c
index 48d9021..ffa2235 100644
--- a/unix/tkUnixWm.c
+++ b/unix/tkUnixWm.c
@@ -41,6 +41,7 @@ typedef struct ProtocolHandler {
/*
* Data for [wm attributes] command:
*/
+
typedef struct {
double alpha; /* Transparency; 0.0=transparent, 1.0=opaque */
int topmost; /* Flag: true=>stay-on-top */
@@ -277,6 +278,16 @@ typedef struct TkWmInfo {
#define WM_WITHDRAWN 0x4000
/*
+ * Wrapper for XGetWindowProperty to make it a *bit* less verbose.
+ */
+
+#define GetWindowProperty(wrapperPtr, atom, length, type, typePtr, formatPtr, numItemsPtr, bytesAfterPtr, itemsPtr) \
+ (XGetWindowProperty((wrapperPtr)->display, (wrapperPtr)->window, \
+ (atom), 0, (long) (length), False, (type), \
+ (typePtr),(formatPtr),(numItemsPtr),(bytesAfterPtr), \
+ (unsigned char **) (itemsPtr)) == Success)
+
+/*
* This module keeps a list of all top-level windows, primarily to simplify
* the job of Tk_CoordsToWindow. The list is called firstWmPtr and is stored
* in the TkDisplay structure.
@@ -1041,9 +1052,8 @@ Tk_WmObjCmd(
return TCL_ERROR;
}
if (objc == 2) {
- Tcl_SetResult(interp,
- ((dispPtr->flags & TK_DISPLAY_WM_TRACING) ? "on" : "off"),
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
+ dispPtr->flags & TK_DISPLAY_WM_TRACING));
return TCL_OK;
}
if (Tcl_GetBooleanFromObj(interp, objv[2], &wmTracing) != TCL_OK) {
@@ -1183,12 +1193,13 @@ WmAspectCmd(
}
if (objc == 3) {
if (wmPtr->sizeHintsFlags & PAspect) {
- char buf[TCL_INTEGER_SPACE * 4];
+ Tcl_Obj *results[4];
- sprintf(buf, "%d %d %d %d", wmPtr->minAspect.x,
- wmPtr->minAspect.y, wmPtr->maxAspect.x,
- wmPtr->maxAspect.y);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ results[0] = Tcl_NewIntObj(wmPtr->minAspect.x);
+ results[1] = Tcl_NewIntObj(wmPtr->minAspect.y);
+ results[2] = Tcl_NewIntObj(wmPtr->maxAspect.x);
+ results[3] = Tcl_NewIntObj(wmPtr->maxAspect.y);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(4, results));
}
return TCL_OK;
}
@@ -1450,7 +1461,8 @@ WmClientCmd(
}
if (objc == 3) {
if (wmPtr->clientMachine != NULL) {
- Tcl_SetResult(interp, wmPtr->clientMachine, TCL_STATIC);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(wmPtr->clientMachine, -1));
}
return TCL_OK;
}
@@ -1530,8 +1542,7 @@ WmColormapwindowsCmd(
Window *cmapList;
TkWindow *winPtr2;
int count, i, windowObjc, gotToplevel;
- Tcl_Obj **windowObjv;
- char buffer[20];
+ Tcl_Obj **windowObjv, *resultObj;
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "window ?windowList?");
@@ -1546,6 +1557,7 @@ WmColormapwindowsCmd(
wmPtr->wrapperPtr->window, &cmapList, &count) == 0) {
return TCL_OK;
}
+ resultObj = Tcl_NewObj();
for (i = 0; i < count; i++) {
if ((i == (count-1))
&& (wmPtr->flags & WM_ADDED_TOPLEVEL_COLORMAP)) {
@@ -1554,13 +1566,15 @@ WmColormapwindowsCmd(
winPtr2 = (TkWindow *)
Tk_IdToWindow(winPtr->display, cmapList[i]);
if (winPtr2 == NULL) {
- sprintf(buffer, "0x%lx", cmapList[i]);
- Tcl_AppendElement(interp, buffer);
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_ObjPrintf("0x%lx", cmapList[i]));
} else {
- Tcl_AppendElement(interp, winPtr2->pathName);
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(winPtr2->pathName, -1));
}
}
XFree((char *) cmapList);
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
if (Tcl_ListObjGetElements(interp, objv[3], &windowObjc, &windowObjv)
@@ -1636,6 +1650,7 @@ WmCommandCmd(
}
if (objc == 3) {
if (wmPtr->cmdArgv != NULL) {
+ /* TODO: Convert this to work with the Tcl_Obj API */
char *arg = Tcl_Merge(wmPtr->cmdArgc, wmPtr->cmdArgv);
Tcl_SetResult(interp, arg, TCL_DYNAMIC);
@@ -1844,7 +1859,6 @@ WmFrameCmd(
{
register WmInfo *wmPtr = winPtr->wmInfoPtr;
Window window;
- char buf[TCL_INTEGER_SPACE];
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "window");
@@ -1854,8 +1868,7 @@ WmFrameCmd(
if (window == None) {
window = Tk_WindowId((Tk_Window) winPtr);
}
- sprintf(buf, "0x%x", (unsigned) window);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("0x%x", (unsigned) window));
return TCL_OK;
}
@@ -1894,8 +1907,6 @@ WmGeometryCmd(
return TCL_ERROR;
}
if (objc == 3) {
- char buf[16 + TCL_INTEGER_SPACE * 4];
-
xSign = (wmPtr->flags & WM_NEGATIVE_X) ? '-' : '+';
ySign = (wmPtr->flags & WM_NEGATIVE_Y) ? '-' : '+';
if (wmPtr->gridWin != NULL) {
@@ -1907,9 +1918,8 @@ WmGeometryCmd(
width = winPtr->changes.width;
height = winPtr->changes.height;
}
- sprintf(buf, "%dx%d%c%d%c%d", width, height, xSign, wmPtr->x,
- ySign, wmPtr->y);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("%dx%d%c%d%c%d",
+ width, height, xSign, wmPtr->x, ySign, wmPtr->y));
return TCL_OK;
}
argv3 = Tcl_GetString(objv[3]);
@@ -1957,12 +1967,13 @@ WmGridCmd(
}
if (objc == 3) {
if (wmPtr->sizeHintsFlags & PBaseSize) {
- char buf[TCL_INTEGER_SPACE * 4];
+ Tcl_Obj *results[4];
- sprintf(buf, "%d %d %d %d", wmPtr->reqGridWidth,
- wmPtr->reqGridHeight, wmPtr->widthInc,
- wmPtr->heightInc);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ results[0] = Tcl_NewIntObj(wmPtr->reqGridWidth);
+ results[1] = Tcl_NewIntObj(wmPtr->reqGridHeight);
+ results[2] = Tcl_NewIntObj(wmPtr->widthInc);
+ results[3] = Tcl_NewIntObj(wmPtr->heightInc);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(4, results));
}
return TCL_OK;
}
@@ -2049,7 +2060,7 @@ WmGroupCmd(
}
if (objc == 3) {
if (wmPtr->hints.flags & WindowGroupHint) {
- Tcl_SetResult(interp, wmPtr->leaderName, TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(wmPtr->leaderName, -1));
}
return TCL_OK;
}
@@ -2123,10 +2134,9 @@ WmIconbitmapCmd(
}
if (objc == 3) {
if (wmPtr->hints.flags & IconPixmapHint) {
- Tcl_SetResult(interp, (char *)
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
Tk_NameOfBitmap(winPtr->display,
- wmPtr->hints.icon_pixmap),
- TCL_STATIC);
+ wmPtr->hints.icon_pixmap), -1));
}
return TCL_OK;
}
@@ -2244,9 +2254,9 @@ WmIconmaskCmd(
}
if (objc == 3) {
if (wmPtr->hints.flags & IconMaskHint) {
- Tcl_SetResult(interp, (char *)
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
Tk_NameOfBitmap(winPtr->display, wmPtr->hints.icon_mask),
- TCL_STATIC);
+ -1));
}
return TCL_OK;
}
@@ -2302,9 +2312,9 @@ WmIconnameCmd(
return TCL_ERROR;
}
if (objc == 3) {
- Tcl_SetResult(interp,
- ((wmPtr->iconName != NULL) ? wmPtr->iconName : ""),
- TCL_STATIC);
+ if (wmPtr->iconName != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(wmPtr->iconName, -1));
+ }
return TCL_OK;
} else {
if (wmPtr->iconName != NULL) {
@@ -2498,11 +2508,11 @@ WmIconpositionCmd(
}
if (objc == 3) {
if (wmPtr->hints.flags & IconPositionHint) {
- char buf[TCL_INTEGER_SPACE * 2];
+ Tcl_Obj *results[2];
- sprintf(buf, "%d %d", wmPtr->hints.icon_x,
- wmPtr->hints.icon_y);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ results[0] = Tcl_NewIntObj(wmPtr->hints.icon_x);
+ results[1] = Tcl_NewIntObj(wmPtr->hints.icon_y);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, results));
}
return TCL_OK;
}
@@ -2731,11 +2741,12 @@ WmMaxsizeCmd(
return TCL_ERROR;
}
if (objc == 3) {
- char buf[TCL_INTEGER_SPACE * 2];
+ Tcl_Obj *results[2];
GetMaxSize(wmPtr, &width, &height);
- sprintf(buf, "%d %d", width, height);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ results[0] = Tcl_NewIntObj(width);
+ results[1] = Tcl_NewIntObj(height);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, results));
return TCL_OK;
}
if ((Tcl_GetIntFromObj(interp, objv[3], &width) != TCL_OK)
@@ -2789,10 +2800,11 @@ WmMinsizeCmd(
return TCL_ERROR;
}
if (objc == 3) {
- char buf[TCL_INTEGER_SPACE * 2];
+ Tcl_Obj *results[2];
- sprintf(buf, "%d %d", wmPtr->minWidth, wmPtr->minHeight);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ results[0] = Tcl_NewIntObj(wmPtr->minWidth);
+ results[1] = Tcl_NewIntObj(wmPtr->minHeight);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, results));
return TCL_OK;
}
if ((Tcl_GetIntFromObj(interp, objv[3], &width) != TCL_OK)
@@ -2968,11 +2980,14 @@ WmProtocolCmd(
* Return a list of all defined protocols for the window.
*/
+ Tcl_Obj *resultObj = Tcl_NewObj();
+
for (protPtr = wmPtr->protPtr; protPtr != NULL;
protPtr = protPtr->nextPtr) {
- Tcl_AppendElement(interp,
- Tk_GetAtomName((Tk_Window) winPtr, protPtr->protocol));
+ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
+ Tk_GetAtomName((Tk_Window)winPtr, protPtr->protocol),-1));
}
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
protocol = Tk_InternAtom((Tk_Window) winPtr, Tcl_GetString(objv[3]));
@@ -2984,7 +2999,8 @@ WmProtocolCmd(
for (protPtr = wmPtr->protPtr; protPtr != NULL;
protPtr = protPtr->nextPtr) {
if (protPtr->protocol == protocol) {
- Tcl_SetResult(interp, protPtr->command, TCL_STATIC);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(protPtr->command, -1));
return TCL_OK;
}
}
@@ -3066,12 +3082,11 @@ WmResizableCmd(
return TCL_ERROR;
}
if (objc == 3) {
- char buf[TCL_INTEGER_SPACE * 2];
+ Tcl_Obj *results[2];
- sprintf(buf, "%d %d",
- (wmPtr->flags & WM_WIDTH_NOT_RESIZABLE) ? 0 : 1,
- (wmPtr->flags & WM_HEIGHT_NOT_RESIZABLE) ? 0 : 1);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ results[0] = Tcl_NewBooleanObj(!(wmPtr->flags&WM_WIDTH_NOT_RESIZABLE));
+ results[1] = Tcl_NewBooleanObj(!(wmPtr->flags&WM_HEIGHT_NOT_RESIZABLE));
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, results));
return TCL_OK;
}
if ((Tcl_GetBooleanFromObj(interp, objv[3], &width) != TCL_OK)
@@ -3198,11 +3213,15 @@ WmStackorderCmd(
if (objc == 3) {
windows = TkWmStackorderToplevel(winPtr);
if (windows != NULL) {
+ Tcl_Obj *resultObj = Tcl_NewObj();
+
/* ASSERT: true [Bug 1789819]*/
for (window_ptr = windows; *window_ptr ; window_ptr++) {
- Tcl_AppendElement(interp, (*window_ptr)->pathName);
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj((*window_ptr)->pathName, -1));
}
ckfree(windows);
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
} else {
@@ -3350,17 +3369,20 @@ WmStateCmd(
}
}
} else {
+ const char *state;
+
if (wmPtr->iconFor != NULL) {
- Tcl_SetResult(interp, "icon", TCL_STATIC);
+ state = "icon";
} else if (wmPtr->withdrawn) {
- Tcl_SetResult(interp, "withdrawn", TCL_STATIC);
+ state = "withdrawn";
} else if (Tk_IsMapped((Tk_Window) winPtr)
|| ((wmPtr->flags & WM_NEVER_MAPPED)
&& (wmPtr->hints.initial_state == NormalState))) {
- Tcl_SetResult(interp, "normal", TCL_STATIC);
+ state = "normal";
} else {
- Tcl_SetResult(interp, "iconic", TCL_STATIC);
+ state = "iconic";
}
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(state, -1));
}
return TCL_OK;
}
@@ -3399,10 +3421,11 @@ WmTitleCmd(
return TCL_ERROR;
}
if (objc == 3) {
- Tcl_SetResult(interp, (char *)
- ((wmPtr->title != NULL) ? wmPtr->title : winPtr->nameUid),
- TCL_STATIC);
- return TCL_OK;
+ if (wmPtr->title) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(wmPtr->title, -1));
+ } else {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(winPtr->nameUid, -1));
+ }
} else {
if (wmPtr->title != NULL) {
ckfree(wmPtr->title);
@@ -4052,6 +4075,8 @@ ReparentEvent(
unsigned dummy;
Tk_ErrorHandler handler;
TkDisplay *dispPtr = wmPtr->winPtr->dispPtr;
+ Atom WM_ROOT = Tk_InternAtom((Tk_Window) wrapperPtr, "__WM_ROOT");
+ Atom SWM_ROOT = Tk_InternAtom((Tk_Window) wrapperPtr, "__SWM_ROOT");
/*
* Identify the root window for wrapperPtr. This is tricky because of
@@ -4065,15 +4090,11 @@ ReparentEvent(
wmPtr->vRoot = None;
handler = Tk_CreateErrorHandler(wrapperPtr->display, -1,-1,-1, NULL,NULL);
vrPtrPtr = &virtualRootPtr; /* Silence GCC warning */
- if (((XGetWindowProperty(wrapperPtr->display, wrapperPtr->window,
- Tk_InternAtom((Tk_Window) wrapperPtr, "__WM_ROOT"), 0, (long) 1,
- False, XA_WINDOW, &actualType, &actualFormat, &numItems,
- &bytesAfter, (unsigned char **) vrPtrPtr) == Success)
+ if ((GetWindowProperty(wrapperPtr, WM_ROOT, 1, XA_WINDOW,
+ &actualType, &actualFormat, &numItems, &bytesAfter, vrPtrPtr)
&& (actualType == XA_WINDOW))
- || ((XGetWindowProperty(wrapperPtr->display, wrapperPtr->window,
- Tk_InternAtom((Tk_Window) wrapperPtr, "__SWM_ROOT"), 0, (long) 1,
- False, XA_WINDOW, &actualType, &actualFormat, &numItems,
- &bytesAfter, (unsigned char **) vrPtrPtr) == Success)
+ || (GetWindowProperty(wrapperPtr, SWM_ROOT, 1, XA_WINDOW,
+ &actualType, &actualFormat, &numItems, &bytesAfter, vrPtrPtr)
&& (actualType == XA_WINDOW))) {
if ((actualFormat == 32) && (numItems == 1)) {
vRoot = wmPtr->vRoot = *virtualRootPtr;
@@ -4285,11 +4306,9 @@ PropertyEvent(
unsigned char *propertyValue = 0;
long maxLength = 1024;
- if (XGetWindowProperty(
- wrapperPtr->display, wrapperPtr->window, _NET_WM_STATE,
- 0l, maxLength, False, XA_ATOM,
+ if (GetWindowProperty(wrapperPtr, _NET_WM_STATE, maxLength, XA_ATOM,
&actualType, &actualFormat, &numItems, &bytesAfter,
- &propertyValue) == Success) {
+ &propertyValue)) {
CheckNetWmState(wmPtr, (Atom *) propertyValue, (int) numItems);
XFree(propertyValue);
}
@@ -5446,13 +5465,12 @@ GetNetWmType(TkWindow *winPtr)
wrapperPtr = winPtr->wmInfoPtr->wrapperPtr;
typeAtom = Tk_InternAtom(tkwin, "_NET_WM_WINDOW_TYPE");
- if (Success == XGetWindowProperty(wrapperPtr->display,
- wrapperPtr->window, typeAtom, 0L, maxLength, False,
- XA_ATOM, &actualType, &actualFormat, &count,
- &bytesAfter, &propertyValue)) {
- atoms = (Atom *)propertyValue;
+ if (GetWindowProperty(wrapperPtr, typeAtom, maxLength, XA_ATOM,
+ &actualType, &actualFormat, &count, &bytesAfter, &propertyValue)){
+ atoms = (Atom *) propertyValue;
for (n = 0; n < count; ++n) {
const char *name = Tk_GetAtomName(tkwin, atoms[n]);
+
if (strncmp("_NET_WM_WINDOW_TYPE_", name, 20) == 0) {
Tcl_ExternalToUtfDString(NULL, name+20, -1, &ds);
Tcl_UtfToLower(Tcl_DStringValue(&ds));
diff --git a/win/tkWinDialog.c b/win/tkWinDialog.c
index 4d60105..b0c7f4d 100644
--- a/win/tkWinDialog.c
+++ b/win/tkWinDialog.c
@@ -424,13 +424,11 @@ Tk_ChooseColorObjCmd(
/*
* User has selected a color
*/
- char color[100];
- sprintf(color, "#%02x%02x%02x",
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("#%02x%02x%02x",
GetRValue(chooseColor.rgbResult),
GetGValue(chooseColor.rgbResult),
- GetBValue(chooseColor.rgbResult));
- Tcl_AppendResult(interp, color, NULL);
+ GetBValue(chooseColor.rgbResult)));
oldColor = chooseColor.rgbResult;
result = TCL_OK;
}
diff --git a/win/tkWinSend.c b/win/tkWinSend.c
index b3edc62..a8e2109 100644
--- a/win/tkWinSend.c
+++ b/win/tkWinSend.c
@@ -55,7 +55,7 @@ typedef struct {
int initialized;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
-#endif
+#endif /* TK_SEND_ENABLED_ON_WINDOWS */
/*
* Functions internal to this file.
@@ -66,12 +66,12 @@ static void CmdDeleteProc(ClientData clientData);
static void InterpDeleteProc(ClientData clientData,
Tcl_Interp *interp);
static void RevokeObjectRegistration(RegisteredInterp *riPtr);
-#endif
+#endif /* TK_SEND_ENABLED_ON_WINDOWS */
static HRESULT BuildMoniker(const char *name, LPMONIKER *pmk);
#ifdef TK_SEND_ENABLED_ON_WINDOWS
static HRESULT RegisterInterp(const char *name,
RegisteredInterp *riPtr);
-#endif
+#endif /* TK_SEND_ENABLED_ON_WINDOWS */
static int FindInterpreterObject(Tcl_Interp *interp,
const char *name, LPDISPATCH *ppdisp);
static int Send(LPDISPATCH pdispInterp, Tcl_Interp *interp,
@@ -85,7 +85,7 @@ static Tcl_EventProc SendEventProc;
#define TRACE SendTrace
#else
#define TRACE 1 ? ((void)0) : SendTrace
-#endif
+#endif /* DEBUG || _DEBUG */
/*
*--------------------------------------------------------------
@@ -553,7 +553,7 @@ RevokeObjectRegistration(
riPtr->name = NULL;
}
}
-#endif
+#endif /* TK_SEND_ENABLED_ON_WINDOWS */
/*
* ----------------------------------------------------------------------
@@ -580,7 +580,7 @@ InterpDeleteProc(
{
CoUninitialize();
}
-#endif
+#endif /* TK_SEND_ENABLED_ON_WINDOWS */
/*
* ----------------------------------------------------------------------
@@ -701,7 +701,7 @@ RegisterInterp(
Tcl_DStringFree(&dString);
return hr;
}
-#endif
+#endif /* TK_SEND_ENABLED_ON_WINDOWS */
/*
* ----------------------------------------------------------------------
@@ -782,21 +782,14 @@ Send(
* variables.
*/
- if (hr == DISP_E_EXCEPTION) {
+ if (hr == DISP_E_EXCEPTION && ei.bstrSource != NULL) {
Tcl_Obj *opError, *opErrorCode, *opErrorInfo;
- if (ei.bstrSource != NULL) {
- int len;
- const char *szErrorInfo;
-
- opError = Tcl_NewUnicodeObj(ei.bstrSource, -1);
- Tcl_ListObjIndex(interp, opError, 0, &opErrorCode);
- Tcl_SetObjErrorCode(interp, opErrorCode);
-
- Tcl_ListObjIndex(interp, opError, 1, &opErrorInfo);
- szErrorInfo = Tcl_GetStringFromObj(opErrorInfo, &len);
- Tcl_AddObjErrorInfo(interp, szErrorInfo, len);
- }
+ opError = Tcl_NewUnicodeObj(ei.bstrSource, -1);
+ Tcl_ListObjIndex(interp, opError, 0, &opErrorCode);
+ Tcl_SetObjErrorCode(interp, opErrorCode);
+ Tcl_ListObjIndex(interp, opError, 1, &opErrorInfo);
+ Tcl_AppendObjToErrorInfo(interp, opErrorInfo);
}
/*
@@ -852,7 +845,7 @@ Win32ErrorObj(
errPtr = Tcl_NewUnicodeObj(lpBuffer, (int)wcslen(lpBuffer));
#else
errPtr = Tcl_NewStringObj(lpBuffer, (int)strlen(lpBuffer));
-#endif
+#endif /* _UNICODE */
if (lpBuffer != sBuffer) {
LocalFree((HLOCAL)lpBuffer);
@@ -864,7 +857,7 @@ Win32ErrorObj(
/*
* ----------------------------------------------------------------------
*
- * SetErrorInfo --
+ * TkWinSend_SetExcepInfo --
*
* Convert the error information from a Tcl interpreter into a COM
* exception structure. This information is then registered with the COM
@@ -881,48 +874,51 @@ Win32ErrorObj(
*/
void
-SetExcepInfo(
- Tcl_Interp* interp,
+TkWinSend_SetExcepInfo(
+ Tcl_Interp *interp,
EXCEPINFO *pExcepInfo)
{
- if (pExcepInfo) {
- Tcl_Obj *opError, *opErrorInfo, *opErrorCode;
- ICreateErrorInfo *pCEI;
- IErrorInfo *pEI, **ppEI = &pEI;
- HRESULT hr;
-
- opError = Tcl_GetObjResult(interp);
- opErrorInfo = Tcl_GetVar2Ex(interp, "errorInfo",NULL, TCL_GLOBAL_ONLY);
- opErrorCode = Tcl_GetVar2Ex(interp, "errorCode",NULL, TCL_GLOBAL_ONLY);
-
- if (Tcl_IsShared(opErrorCode)) {
- Tcl_Obj *ec = Tcl_DuplicateObj(opErrorCode);
-
- Tcl_IncrRefCount(ec);
- Tcl_DecrRefCount(opErrorCode);
- opErrorCode = ec;
- }
- Tcl_ListObjAppendElement(interp, opErrorCode, opErrorInfo);
+ Tcl_Obj *opError, *opErrorInfo, *opErrorCode;
+ ICreateErrorInfo *pCEI;
+ IErrorInfo *pEI, **ppEI = &pEI;
+ HRESULT hr;
- pExcepInfo->bstrDescription = SysAllocString(Tcl_GetUnicode(opError));
- pExcepInfo->bstrSource = SysAllocString(Tcl_GetUnicode(opErrorCode));
- pExcepInfo->scode = E_FAIL;
+ if (!pExcepInfo) {
+ return;
+ }
- hr = CreateErrorInfo(&pCEI);
- if (SUCCEEDED(hr)) {
- hr = pCEI->lpVtbl->SetGUID(pCEI, &IID_IDispatch);
- hr = pCEI->lpVtbl->SetDescription(pCEI,
- pExcepInfo->bstrDescription);
- hr = pCEI->lpVtbl->SetSource(pCEI, pExcepInfo->bstrSource);
- hr = pCEI->lpVtbl->QueryInterface(pCEI, &IID_IErrorInfo,
- (void**) ppEI);
- if (SUCCEEDED(hr)) {
- SetErrorInfo(0, pEI);
- pEI->lpVtbl->Release(pEI);
- }
- pCEI->lpVtbl->Release(pCEI);
- }
+ opError = Tcl_GetObjResult(interp);
+ opErrorInfo = Tcl_GetVar2Ex(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
+ opErrorCode = Tcl_GetVar2Ex(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
+
+ /*
+ * Pack the trace onto the end of the Tcl exception descriptor.
+ */
+
+ opErrorCode = Tcl_DuplicateObj(opErrorCode);
+ Tcl_IncrRefCount(opErrorCode);
+ Tcl_ListObjAppendElement(interp, opErrorCode, opErrorInfo);
+ /* TODO: Handle failure to append */
+
+ pExcepInfo->bstrDescription = SysAllocString(Tcl_GetUnicode(opError));
+ pExcepInfo->bstrSource = SysAllocString(Tcl_GetUnicode(opErrorCode));
+ Tcl_DecrRefCount(opErrorCode);
+ pExcepInfo->scode = E_FAIL;
+
+ hr = CreateErrorInfo(&pCEI);
+ if (!SUCCEEDED(hr)) {
+ return;
+ }
+
+ hr = pCEI->lpVtbl->SetGUID(pCEI, &IID_IDispatch);
+ hr = pCEI->lpVtbl->SetDescription(pCEI, pExcepInfo->bstrDescription);
+ hr = pCEI->lpVtbl->SetSource(pCEI, pExcepInfo->bstrSource);
+ hr = pCEI->lpVtbl->QueryInterface(pCEI, &IID_IErrorInfo, (void **) ppEI);
+ if (SUCCEEDED(hr)) {
+ SetErrorInfo(0, pEI);
+ pEI->lpVtbl->Release(pEI);
}
+ pCEI->lpVtbl->Release(pCEI);
}
/*
diff --git a/win/tkWinSendCom.c b/win/tkWinSendCom.c
index c67e533..83dd56b 100644
--- a/win/tkWinSendCom.c
+++ b/win/tkWinSendCom.c
@@ -100,7 +100,6 @@ TkWinSendCom_CreateInstance(
ISupportErrorInfo_Release,
ISupportErrorInfo_InterfaceSupportsErrorInfo,
};
- HRESULT hr = S_OK;
TkWinSendCom *obj = NULL;
/*
@@ -111,21 +110,19 @@ TkWinSendCom_CreateInstance(
obj = (TkWinSendCom *) CoTaskMemAlloc(sizeof(TkWinSendCom));
if (obj == NULL) {
*ppv = NULL;
- hr = E_OUTOFMEMORY;
- } else {
- obj->lpVtbl = &vtbl;
- obj->lpVtbl2 = &vtbl2;
- obj->refcount = 0;
- obj->interp = interp;
-
- /*
- * lock the interp? Tcl_AddRef/Retain?
- */
-
- hr = obj->lpVtbl->QueryInterface((IDispatch*)obj, riid, ppv);
+ return E_OUTOFMEMORY;
}
- return hr;
+ obj->lpVtbl = &vtbl;
+ obj->lpVtbl2 = &vtbl2;
+ obj->refcount = 0;
+ obj->interp = interp;
+
+ /*
+ * lock the interp? Tcl_AddRef/Retain?
+ */
+
+ return obj->lpVtbl->QueryInterface((IDispatch *) obj, riid, ppv);
}
/*
@@ -147,7 +144,7 @@ static void
TkWinSendCom_Destroy(
LPDISPATCH pdisp)
{
- CoTaskMemFree((void*)pdisp);
+ CoTaskMemFree((void *) pdisp);
}
/*
@@ -169,17 +166,17 @@ WinSendCom_QueryInterface(
void **ppvObject)
{
HRESULT hr = E_NOINTERFACE;
- TkWinSendCom *this = (TkWinSendCom*)This;
+ TkWinSendCom *this = (TkWinSendCom *) This;
*ppvObject = NULL;
if (memcmp(riid, &IID_IUnknown, sizeof(IID)) == 0
|| memcmp(riid, &IID_IDispatch, sizeof(IID)) == 0) {
- *ppvObject = (void**)this;
+ *ppvObject = (void **) this;
this->lpVtbl->AddRef(This);
hr = S_OK;
} else if (memcmp(riid, &IID_ISupportErrorInfo, sizeof(IID)) == 0) {
- *ppvObject = (void**)(this + 1);
- this->lpVtbl2->AddRef((ISupportErrorInfo*)(this + 1));
+ *ppvObject = (void **) (this + 1);
+ this->lpVtbl2->AddRef((ISupportErrorInfo *) (this + 1));
hr = S_OK;
}
return hr;
@@ -316,16 +313,16 @@ ISupportErrorInfo_QueryInterface(
REFIID riid,
void **ppvObject)
{
- TkWinSendCom *this = (TkWinSendCom*)(This - 1);
+ TkWinSendCom *this = (TkWinSendCom *)(This - 1);
- return this->lpVtbl->QueryInterface((IDispatch*)this, riid, ppvObject);
+ return this->lpVtbl->QueryInterface((IDispatch *) this, riid, ppvObject);
}
static STDMETHODIMP_(ULONG)
ISupportErrorInfo_AddRef(
ISupportErrorInfo *This)
{
- TkWinSendCom *this = (TkWinSendCom*)(This - 1);
+ TkWinSendCom *this = (TkWinSendCom *)(This - 1);
return InterlockedIncrement(&this->refcount);
}
@@ -334,9 +331,9 @@ static STDMETHODIMP_(ULONG)
ISupportErrorInfo_Release(
ISupportErrorInfo *This)
{
- TkWinSendCom *this = (TkWinSendCom*)(This - 1);
+ TkWinSendCom *this = (TkWinSendCom *)(This - 1);
- return this->lpVtbl->Release((IDispatch*)this);
+ return this->lpVtbl->Release((IDispatch *) this);
}
static STDMETHODIMP
@@ -380,17 +377,15 @@ Async(
if (FAILED(hr)) {
Tcl_SetObjResult(obj->interp, Tcl_NewStringObj(
"invalid args: Async(command)", -1));
- SetExcepInfo(obj->interp, pExcepInfo);
+ TkWinSend_SetExcepInfo(obj->interp, pExcepInfo);
hr = DISP_E_EXCEPTION;
}
- if (SUCCEEDED(hr)) {
- if (obj->interp) {
- Tcl_Obj *scriptPtr = Tcl_NewUnicodeObj(vCmd.bstrVal,
- (int) SysStringLen(vCmd.bstrVal));
+ if (SUCCEEDED(hr) && obj->interp) {
+ Tcl_Obj *scriptPtr = Tcl_NewUnicodeObj(vCmd.bstrVal,
+ (int) SysStringLen(vCmd.bstrVal));
- TkWinSend_QueueCommand(obj->interp, scriptPtr);
- }
+ TkWinSend_QueueCommand(obj->interp, scriptPtr);
}
VariantClear(&vCmd);
@@ -427,29 +422,36 @@ Send(
HRESULT hr = S_OK;
int result = TCL_OK;
VARIANT v;
+ register Tcl_Interp *interp = obj->interp;
+ Tcl_Obj *scriptPtr;
+ if (interp == NULL) {
+ return S_OK;
+ }
VariantInit(&v);
hr = VariantChangeType(&v, &vCmd, 0, VT_BSTR);
- if (SUCCEEDED(hr)) {
- if (obj->interp) {
- Tcl_Obj *scriptPtr = Tcl_NewUnicodeObj(v.bstrVal,
- (int)SysStringLen(v.bstrVal));
-
- result = Tcl_EvalObjEx(obj->interp, scriptPtr,
- TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL);
- if (pvResult) {
- VariantInit(pvResult);
- pvResult->vt = VT_BSTR;
- pvResult->bstrVal = SysAllocString(
- Tcl_GetUnicode(Tcl_GetObjResult(obj->interp)));
- }
- if (result == TCL_ERROR) {
- hr = DISP_E_EXCEPTION;
- SetExcepInfo(obj->interp, pExcepInfo);
- }
- }
- VariantClear(&v);
+ if (!SUCCEEDED(hr)) {
+ return hr;
+ }
+
+ scriptPtr = Tcl_NewUnicodeObj(v.bstrVal, (int) SysStringLen(v.bstrVal));
+ Tcl_Preserve(interp);
+ Tcl_IncrRefCount(scriptPtr);
+ result = Tcl_EvalObjEx(interp, scriptPtr,
+ TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL);
+ Tcl_DecrRefCount(scriptPtr);
+ if (pvResult != NULL) {
+ VariantInit(pvResult);
+ pvResult->vt = VT_BSTR;
+ pvResult->bstrVal = SysAllocString(Tcl_GetUnicode(
+ Tcl_GetObjResult(interp)));
+ }
+ if (result == TCL_ERROR) {
+ hr = DISP_E_EXCEPTION;
+ TkWinSend_SetExcepInfo(interp, pExcepInfo);
}
+ Tcl_Release(interp);
+ VariantClear(&v);
return hr;
}
diff --git a/win/tkWinSendCom.h b/win/tkWinSendCom.h
index 4928bc7..cd6ec18 100644
--- a/win/tkWinSendCom.h
+++ b/win/tkWinSendCom.h
@@ -45,11 +45,11 @@ typedef struct {
* TkWinSendCom public functions
*/
-HRESULT TkWinSendCom_CreateInstance(Tcl_Interp *interp,
+MODULE_SCOPE HRESULT TkWinSendCom_CreateInstance(Tcl_Interp *interp,
REFIID riid, void **ppv);
-int TkWinSend_QueueCommand(Tcl_Interp *interp,
+MODULE_SCOPE int TkWinSend_QueueCommand(Tcl_Interp *interp,
Tcl_Obj *cmdPtr);
-void SetExcepInfo(Tcl_Interp *interp,
+MODULE_SCOPE void TkWinSend_SetExcepInfo(Tcl_Interp *interp,
EXCEPINFO *pExcepInfo);
#endif /* _tkWinSendCom_h_INCLUDE */
diff --git a/win/tkWinX.c b/win/tkWinX.c
index e85b7e7..22edb60 100644
--- a/win/tkWinX.c
+++ b/win/tkWinX.c
@@ -120,20 +120,19 @@ TkGetServerInfo(
Tk_Window tkwin) /* Token for window; this selects a particular
* display and server. */
{
- char buffer[60];
OSVERSIONINFO os;
os.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
GetVersionEx(&os);
- sprintf(buffer, "Windows %d.%d %d %s", (int)os.dwMajorVersion,
- (int)os.dwMinorVersion, (int)os.dwBuildNumber,
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("Windows %d.%d %d %s",
+ (int) os.dwMajorVersion, (int) os.dwMinorVersion,
+ (int) os.dwBuildNumber,
#ifdef _WIN64
"Win64"
#else
"Win32"
#endif
- );
- Tcl_SetResult(interp, buffer, TCL_VOLATILE);
+ ));
}
/*