diff options
Diffstat (limited to 'generic/tkUtil.c')
| -rw-r--r-- | generic/tkUtil.c | 1133 |
1 files changed, 613 insertions, 520 deletions
diff --git a/generic/tkUtil.c b/generic/tkUtil.c index 3d04657..5282708 100644 --- a/generic/tkUtil.c +++ b/generic/tkUtil.c @@ -1,68 +1,65 @@ -/* +/* * tkUtil.c -- * - * This file contains miscellaneous utility procedures that - * are used by the rest of Tk, such as a procedure for drawing - * a focus highlight. + * This file contains miscellaneous utility functions that are used by + * the rest of Tk, such as a function for drawing a focus highlight. * * Copyright (c) 1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkInt.h" -#include "tkPort.h" /* - * The structure below defines the implementation of the "statekey" - * Tcl object, used for quickly finding a mapping in a TkStateMap. + * The structure below defines the implementation of the "statekey" Tcl + * object, used for quickly finding a mapping in a TkStateMap. */ -Tcl_ObjType tkStateKeyObjType = { - "statekey", /* name */ - (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ - (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ - (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ - (Tcl_SetFromAnyProc *) NULL /* setFromAnyProc */ +const Tcl_ObjType tkStateKeyObjType = { + "statekey", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ }; - /* *-------------------------------------------------------------- * * TkStateParseProc -- * - * This procedure is invoked during option processing to handle - * the "-state" and "-default" options. + * This function is invoked during option processing to handle the + * "-state" and "-default" options. * * Results: * A standard Tcl return value. * * Side effects: - * The state for a given item gets replaced by the state - * indicated in the value argument. + * The state for a given item gets replaced by the state indicated in the + * value argument. * *-------------------------------------------------------------- */ int -TkStateParseProc(clientData, interp, tkwin, value, widgRec, offset) - ClientData clientData; /* some flags.*/ - Tcl_Interp *interp; /* Used for reporting errors. */ - Tk_Window tkwin; /* Window containing canvas widget. */ - CONST char *value; /* Value of option. */ - char *widgRec; /* Pointer to record for item. */ - int offset; /* Offset into item. */ +TkStateParseProc( + ClientData clientData, /* some flags.*/ + Tcl_Interp *interp, /* Used for reporting errors. */ + Tk_Window tkwin, /* Window containing canvas widget. */ + const char *value, /* Value of option. */ + char *widgRec, /* Pointer to record for item. */ + int offset) /* Offset into item. */ { int c; - int flags = (int)clientData; + int flags = PTR2INT(clientData); size_t length; register Tk_State *statePtr = (Tk_State *) (widgRec + offset); - if(value == NULL || *value == 0) { + if (value == NULL || *value == 0) { *statePtr = TK_STATE_NULL; return TCL_OK; } @@ -88,18 +85,17 @@ TkStateParseProc(clientData, interp, tkwin, value, widgRec, offset) } Tcl_AppendResult(interp, "bad ", (flags&4)?"-default" : "state", - " value \"", value, "\": must be normal", - (char *) NULL); + " value \"", value, "\": must be normal", NULL); if (flags&1) { - Tcl_AppendResult(interp, ", active",(char *) NULL); + Tcl_AppendResult(interp, ", active", NULL); } if (flags&2) { - Tcl_AppendResult(interp, ", hidden",(char *) NULL); + Tcl_AppendResult(interp, ", hidden", NULL); } if (flags&3) { - Tcl_AppendResult(interp, ",",(char *) NULL); + Tcl_AppendResult(interp, ",", NULL); } - Tcl_AppendResult(interp, " or disabled",(char *) NULL); + Tcl_AppendResult(interp, " or disabled", NULL); *statePtr = TK_STATE_NORMAL; return TCL_ERROR; } @@ -109,16 +105,15 @@ TkStateParseProc(clientData, interp, tkwin, value, widgRec, offset) * * TkStatePrintProc -- * - * This procedure is invoked by the Tk configuration code - * to produce a printable string for the "-state" - * configuration option. + * This function is invoked by the Tk configuration code to produce a + * printable string for the "-state" configuration option. * * Results: - * The return value is a string describing the state for - * the item referred to by "widgRec". In addition, *freeProcPtr - * is filled in with the address of a procedure to call to free - * the result string when it's no longer needed (or NULL to - * indicate that the string doesn't need to be freed). + * The return value is a string describing the state for the item + * referred to by "widgRec". In addition, *freeProcPtr is filled in with + * the address of a function to call to free the result string when it's + * no longer needed (or NULL to indicate that the string doesn't need to + * be freed). * * Side effects: * None. @@ -126,27 +121,28 @@ TkStateParseProc(clientData, interp, tkwin, value, widgRec, offset) *-------------------------------------------------------------- */ -char * -TkStatePrintProc(clientData, tkwin, widgRec, offset, freeProcPtr) - ClientData clientData; /* Ignored. */ - Tk_Window tkwin; /* Window containing canvas widget. */ - char *widgRec; /* Pointer to record for item. */ - int offset; /* Offset into item. */ - Tcl_FreeProc **freeProcPtr; /* Pointer to variable to fill in with - * information about how to reclaim - * storage for return string. */ +const char * +TkStatePrintProc( + ClientData clientData, /* Ignored. */ + Tk_Window tkwin, /* Window containing canvas widget. */ + char *widgRec, /* Pointer to record for item. */ + int offset, /* Offset into item. */ + Tcl_FreeProc **freeProcPtr) /* Pointer to variable to fill in with + * information about how to reclaim storage + * for return string. */ { register Tk_State *statePtr = (Tk_State *) (widgRec + offset); - if (*statePtr==TK_STATE_NORMAL) { + switch (*statePtr) { + case TK_STATE_NORMAL: return "normal"; - } else if (*statePtr==TK_STATE_DISABLED) { + case TK_STATE_DISABLED: return "disabled"; - } else if (*statePtr==TK_STATE_HIDDEN) { + case TK_STATE_HIDDEN: return "hidden"; - } else if (*statePtr==TK_STATE_ACTIVE) { + case TK_STATE_ACTIVE: return "active"; - } else { + default: return ""; } } @@ -156,8 +152,8 @@ TkStatePrintProc(clientData, tkwin, widgRec, offset, freeProcPtr) * * TkOrientParseProc -- * - * This procedure is invoked during option processing to handle - * the "-orient" option. + * This function is invoked during option processing to handle the + * "-orient" option. * * Results: * A standard Tcl return value. @@ -170,20 +166,20 @@ TkStatePrintProc(clientData, tkwin, widgRec, offset, freeProcPtr) */ int -TkOrientParseProc(clientData, interp, tkwin, value, widgRec, offset) - ClientData clientData; /* some flags.*/ - Tcl_Interp *interp; /* Used for reporting errors. */ - Tk_Window tkwin; /* Window containing canvas widget. */ - CONST char *value; /* Value of option. */ - char *widgRec; /* Pointer to record for item. */ - int offset; /* Offset into item. */ +TkOrientParseProc( + ClientData clientData, /* some flags.*/ + Tcl_Interp *interp, /* Used for reporting errors. */ + Tk_Window tkwin, /* Window containing canvas widget. */ + const char *value, /* Value of option. */ + char *widgRec, /* Pointer to record for item. */ + int offset) /* Offset into item. */ { int c; size_t length; register int *orientPtr = (int *) (widgRec + offset); - if(value == NULL || *value == 0) { + if (value == NULL || *value == 0) { *orientPtr = 0; return TCL_OK; } @@ -200,8 +196,7 @@ TkOrientParseProc(clientData, interp, tkwin, value, widgRec, offset) return TCL_OK; } Tcl_AppendResult(interp, "bad orientation \"", value, - "\": must be vertical or horizontal", - (char *) NULL); + "\": must be vertical or horizontal", NULL); *orientPtr = 0; return TCL_ERROR; } @@ -211,16 +206,15 @@ TkOrientParseProc(clientData, interp, tkwin, value, widgRec, offset) * * TkOrientPrintProc -- * - * This procedure is invoked by the Tk configuration code - * to produce a printable string for the "-orient" - * configuration option. + * This function is invoked by the Tk configuration code to produce a + * printable string for the "-orient" configuration option. * * Results: - * The return value is a string describing the orientation for - * the item referred to by "widgRec". In addition, *freeProcPtr - * is filled in with the address of a procedure to call to free - * the result string when it's no longer needed (or NULL to - * indicate that the string doesn't need to be freed). + * The return value is a string describing the orientation for the item + * referred to by "widgRec". In addition, *freeProcPtr is filled in with + * the address of a function to call to free the result string when it's + * no longer needed (or NULL to indicate that the string doesn't need to + * be freed). * * Side effects: * None. @@ -228,15 +222,15 @@ TkOrientParseProc(clientData, interp, tkwin, value, widgRec, offset) *-------------------------------------------------------------- */ -char * -TkOrientPrintProc(clientData, tkwin, widgRec, offset, freeProcPtr) - ClientData clientData; /* Ignored. */ - Tk_Window tkwin; /* Window containing canvas widget. */ - char *widgRec; /* Pointer to record for item. */ - int offset; /* Offset into item. */ - Tcl_FreeProc **freeProcPtr; /* Pointer to variable to fill in with - * information about how to reclaim - * storage for return string. */ +const char * +TkOrientPrintProc( + ClientData clientData, /* Ignored. */ + Tk_Window tkwin, /* Window containing canvas widget. */ + char *widgRec, /* Pointer to record for item. */ + int offset, /* Offset into item. */ + Tcl_FreeProc **freeProcPtr) /* Pointer to variable to fill in with + * information about how to reclaim storage + * for return string. */ { register int *statePtr = (int *) (widgRec + offset); @@ -252,23 +246,24 @@ TkOrientPrintProc(clientData, tkwin, widgRec, offset, freeProcPtr) * * TkOffsetParseProc -- * - * Converts the offset of a stipple or tile into the Tk_TSOffset structure. + * Converts the offset of a stipple or tile into the Tk_TSOffset + * structure. * *---------------------------------------------------------------------- */ int -TkOffsetParseProc(clientData, interp, tkwin, value, widgRec, offset) - ClientData clientData; /* not used */ - Tcl_Interp *interp; /* Interpreter to send results back to */ - Tk_Window tkwin; /* Window on same display as tile */ - CONST char *value; /* Name of image */ - char *widgRec; /* Widget structure record */ - int offset; /* Offset of tile in record */ +TkOffsetParseProc( + ClientData clientData, /* not used */ + Tcl_Interp *interp, /* Interpreter to send results back to */ + Tk_Window tkwin, /* Window on same display as tile */ + const char *value, /* Name of image */ + char *widgRec, /* Widget structure record */ + int offset) /* Offset of tile in record */ { - Tk_TSOffset *offsetPtr = (Tk_TSOffset *)(widgRec + offset); + Tk_TSOffset *offsetPtr = (Tk_TSOffset *) (widgRec + offset); Tk_TSOffset tsoffset; - CONST char *q, *p; + const char *q, *p; int result; if ((value == NULL) || (*value == 0)) { @@ -278,62 +273,77 @@ TkOffsetParseProc(clientData, interp, tkwin, value, widgRec, offset) tsoffset.flags = 0; p = value; - switch(value[0]) { - case '#': - if (((int)clientData) & TK_OFFSET_RELATIVE) { - tsoffset.flags = TK_OFFSET_RELATIVE; - p++; break; - } - goto badTSOffset; - case 'e': - switch(value[1]) { - case '\0': - tsoffset.flags = TK_OFFSET_RIGHT|TK_OFFSET_MIDDLE; - goto goodTSOffset; - case 'n': - if (value[2]!='d' || value[3]!='\0') {goto badTSOffset;} - tsoffset.flags = INT_MAX; - goto goodTSOffset; - } - case 'w': - if (value[1] != '\0') {goto badTSOffset;} - tsoffset.flags = TK_OFFSET_LEFT|TK_OFFSET_MIDDLE; + switch (value[0]) { + case '#': + if (PTR2INT(clientData) & TK_OFFSET_RELATIVE) { + tsoffset.flags = TK_OFFSET_RELATIVE; + p++; + break; + } + goto badTSOffset; + case 'e': + switch(value[1]) { + case '\0': + tsoffset.flags = TK_OFFSET_RIGHT|TK_OFFSET_MIDDLE; goto goodTSOffset; case 'n': - if ((value[1] != '\0') && (value[2] != '\0')) { + if (value[2]!='d' || value[3]!='\0') { goto badTSOffset; } - switch(value[1]) { - case '\0': tsoffset.flags = TK_OFFSET_CENTER|TK_OFFSET_TOP; - goto goodTSOffset; - case 'w': tsoffset.flags = TK_OFFSET_LEFT|TK_OFFSET_TOP; - goto goodTSOffset; - case 'e': tsoffset.flags = TK_OFFSET_RIGHT|TK_OFFSET_TOP; - goto goodTSOffset; - } + tsoffset.flags = INT_MAX; + goto goodTSOffset; + } + case 'w': + if (value[1] != '\0') {goto badTSOffset;} + tsoffset.flags = TK_OFFSET_LEFT|TK_OFFSET_MIDDLE; + goto goodTSOffset; + case 'n': + if ((value[1] != '\0') && (value[2] != '\0')) { goto badTSOffset; - case 's': - if ((value[1] != '\0') && (value[2] != '\0')) { - goto badTSOffset; - } - switch(value[1]) { - case '\0': tsoffset.flags = TK_OFFSET_CENTER|TK_OFFSET_BOTTOM; - goto goodTSOffset; - case 'w': tsoffset.flags = TK_OFFSET_LEFT|TK_OFFSET_BOTTOM; - goto goodTSOffset; - case 'e': tsoffset.flags = TK_OFFSET_RIGHT|TK_OFFSET_BOTTOM; - goto goodTSOffset; - } + } + switch(value[1]) { + case '\0': + tsoffset.flags = TK_OFFSET_CENTER|TK_OFFSET_TOP; + goto goodTSOffset; + case 'w': + tsoffset.flags = TK_OFFSET_LEFT|TK_OFFSET_TOP; + goto goodTSOffset; + case 'e': + tsoffset.flags = TK_OFFSET_RIGHT|TK_OFFSET_TOP; + goto goodTSOffset; + } + goto badTSOffset; + case 's': + if ((value[1] != '\0') && (value[2] != '\0')) { goto badTSOffset; - case 'c': - if (strncmp(value, "center", strlen(value)) != 0) { - goto badTSOffset; - } - tsoffset.flags = TK_OFFSET_CENTER|TK_OFFSET_MIDDLE; + } + switch(value[1]) { + case '\0': + tsoffset.flags = TK_OFFSET_CENTER|TK_OFFSET_BOTTOM; goto goodTSOffset; + case 'w': + tsoffset.flags = TK_OFFSET_LEFT|TK_OFFSET_BOTTOM; + goto goodTSOffset; + case 'e': + tsoffset.flags = TK_OFFSET_RIGHT|TK_OFFSET_BOTTOM; + goto goodTSOffset; + } + goto badTSOffset; + case 'c': + if (strncmp(value, "center", strlen(value)) != 0) { + goto badTSOffset; + } + tsoffset.flags = TK_OFFSET_CENTER|TK_OFFSET_MIDDLE; + goto goodTSOffset; } - if ((q = strchr(p,',')) == NULL) { - if (((int)clientData) & TK_OFFSET_INDEX) { + + /* + * Check for an extra offset. + */ + + q = strchr(p, ','); + if (q == NULL) { + if (PTR2INT(clientData) & TK_OFFSET_INDEX) { if (Tcl_GetInt(interp, (char *) p, &tsoffset.flags) != TCL_OK) { Tcl_ResetResult(interp); goto badTSOffset; @@ -343,39 +353,38 @@ TkOffsetParseProc(clientData, interp, tkwin, value, widgRec, offset) } goto badTSOffset; } + *((char *) q) = 0; result = Tk_GetPixels(interp, tkwin, (char *) p, &tsoffset.xoffset); *((char *) q) = ','; if (result != TCL_OK) { return TCL_ERROR; } - if (Tk_GetPixels(interp, tkwin, (char *) q+1, &tsoffset.yoffset) != TCL_OK) { + if (Tk_GetPixels(interp, tkwin, (char*)q+1, &tsoffset.yoffset) != TCL_OK) { return TCL_ERROR; } - -goodTSOffset: - /* below is a hack to allow the stipple/tile offset to be stored - * in the internal tile structure. Most of the times, offsetPtr - * is a pointer to an already existing tile structure. However - * if this structure is not already created, we must do it - * with Tk_GetTile()!!!!; + /* + * Below is a hack to allow the stipple/tile offset to be stored in the + * internal tile structure. Most of the times, offsetPtr is a pointer to + * an already existing tile structure. However if this structure is not + * already created, we must do it with Tk_GetTile()!!!! */ - memcpy(offsetPtr,&tsoffset, sizeof(Tk_TSOffset)); + goodTSOffset: + memcpy(offsetPtr, &tsoffset, sizeof(Tk_TSOffset)); return TCL_OK; -badTSOffset: + badTSOffset: Tcl_AppendResult(interp, "bad offset \"", value, - "\": expected \"x,y\"", (char *) NULL); - if (((int) clientData) & TK_OFFSET_RELATIVE) { - Tcl_AppendResult(interp, ", \"#x,y\"", (char *) NULL); + "\": expected \"x,y\"", NULL); + if (PTR2INT(clientData) & TK_OFFSET_RELATIVE) { + Tcl_AppendResult(interp, ", \"#x,y\"", NULL); } - if (((int) clientData) & TK_OFFSET_INDEX) { - Tcl_AppendResult(interp, ", <index>", (char *) NULL); + if (PTR2INT(clientData) & TK_OFFSET_INDEX) { + Tcl_AppendResult(interp, ", <index>", NULL); } - Tcl_AppendResult(interp, ", n, ne, e, se, s, sw, w, nw, or center", - (char *) NULL); + Tcl_AppendResult(interp, ", n, ne, e, se, s, sw, w, nw, or center", NULL); return TCL_ERROR; } @@ -392,61 +401,60 @@ badTSOffset: *---------------------------------------------------------------------- */ -char * -TkOffsetPrintProc(clientData, tkwin, widgRec, offset, freeProcPtr) - ClientData clientData; /* not used */ - Tk_Window tkwin; /* not used */ - char *widgRec; /* Widget structure record */ - int offset; /* Offset of tile in record */ - Tcl_FreeProc **freeProcPtr; /* not used */ +const char * +TkOffsetPrintProc( + ClientData clientData, /* not used */ + Tk_Window tkwin, /* not used */ + char *widgRec, /* Widget structure record */ + int offset, /* Offset of tile in record */ + Tcl_FreeProc **freeProcPtr) /* not used */ { - Tk_TSOffset *offsetPtr = (Tk_TSOffset *)(widgRec + offset); + Tk_TSOffset *offsetPtr = (Tk_TSOffset *) (widgRec + offset); char *p, *q; - if ((offsetPtr->flags) & TK_OFFSET_INDEX) { - if ((offsetPtr->flags) >= INT_MAX) { + if (offsetPtr->flags & TK_OFFSET_INDEX) { + if (offsetPtr->flags >= INT_MAX) { return "end"; } - p = (char *) ckalloc(32); - sprintf(p, "%d",(offsetPtr->flags & (~TK_OFFSET_INDEX))); + p = ckalloc(32); + sprintf(p, "%d", offsetPtr->flags & ~TK_OFFSET_INDEX); *freeProcPtr = TCL_DYNAMIC; return p; } - if ((offsetPtr->flags) & TK_OFFSET_TOP) { - if ((offsetPtr->flags) & TK_OFFSET_LEFT) { + if (offsetPtr->flags & TK_OFFSET_TOP) { + if (offsetPtr->flags & TK_OFFSET_LEFT) { return "nw"; - } else if ((offsetPtr->flags) & TK_OFFSET_CENTER) { + } else if (offsetPtr->flags & TK_OFFSET_CENTER) { return "n"; - } else if ((offsetPtr->flags) & TK_OFFSET_RIGHT) { + } else if (offsetPtr->flags & TK_OFFSET_RIGHT) { return "ne"; } - } else if ((offsetPtr->flags) & TK_OFFSET_MIDDLE) { - if ((offsetPtr->flags) & TK_OFFSET_LEFT) { + } else if (offsetPtr->flags & TK_OFFSET_MIDDLE) { + if (offsetPtr->flags & TK_OFFSET_LEFT) { return "w"; - } else if ((offsetPtr->flags) & TK_OFFSET_CENTER) { + } else if (offsetPtr->flags & TK_OFFSET_CENTER) { return "center"; - } else if ((offsetPtr->flags) & TK_OFFSET_RIGHT) { + } else if (offsetPtr->flags & TK_OFFSET_RIGHT) { return "e"; } - } else if ((offsetPtr->flags) & TK_OFFSET_BOTTOM) { - if ((offsetPtr->flags) & TK_OFFSET_LEFT) { + } else if (offsetPtr->flags & TK_OFFSET_BOTTOM) { + if (offsetPtr->flags & TK_OFFSET_LEFT) { return "sw"; - } else if ((offsetPtr->flags) & TK_OFFSET_CENTER) { + } else if (offsetPtr->flags & TK_OFFSET_CENTER) { return "s"; - } else if ((offsetPtr->flags) & TK_OFFSET_RIGHT) { + } else if (offsetPtr->flags & TK_OFFSET_RIGHT) { return "se"; } - } - q = p = (char *) ckalloc(32); - if ((offsetPtr->flags) & TK_OFFSET_RELATIVE) { + } + q = p = ckalloc(32); + if (offsetPtr->flags & TK_OFFSET_RELATIVE) { *q++ = '#'; } - sprintf(q, "%d,%d",offsetPtr->xoffset, offsetPtr->yoffset); + sprintf(q, "%d,%d", offsetPtr->xoffset, offsetPtr->yoffset); *freeProcPtr = TCL_DYNAMIC; return p; } - /* *---------------------------------------------------------------------- * @@ -458,23 +466,22 @@ TkOffsetPrintProc(clientData, tkwin, widgRec, offset, freeProcPtr) */ int -TkPixelParseProc(clientData, interp, tkwin, value, widgRec, offset) - ClientData clientData; /* if non-NULL, negative values are - * allowed as well */ - Tcl_Interp *interp; /* Interpreter to send results back to */ - Tk_Window tkwin; /* Window on same display as tile */ - CONST char *value; /* Name of image */ - char *widgRec; /* Widget structure record */ - int offset; /* Offset of tile in record */ +TkPixelParseProc( + ClientData clientData, /* If non-NULL, negative values are allowed as + * well. */ + Tcl_Interp *interp, /* Interpreter to send results back to */ + Tk_Window tkwin, /* Window on same display as tile */ + const char *value, /* Name of image */ + char *widgRec, /* Widget structure record */ + int offset) /* Offset of tile in record */ { - double *doublePtr = (double *)(widgRec + offset); + double *doublePtr = (double *) (widgRec + offset); int result; result = TkGetDoublePixels(interp, tkwin, value, doublePtr); if ((result == TCL_OK) && (clientData == NULL) && (*doublePtr < 0.0)) { - Tcl_AppendResult(interp, "bad screen distance \"", value, - "\"", (char *) NULL); + Tcl_AppendResult(interp, "bad screen distance \"", value, "\"", NULL); return TCL_ERROR; } return result; @@ -493,19 +500,18 @@ TkPixelParseProc(clientData, interp, tkwin, value, widgRec, offset) *---------------------------------------------------------------------- */ -char * -TkPixelPrintProc(clientData, tkwin, widgRec, offset, freeProcPtr) - ClientData clientData; /* not used */ - Tk_Window tkwin; /* not used */ - char *widgRec; /* Widget structure record */ - int offset; /* Offset of tile in record */ - Tcl_FreeProc **freeProcPtr; /* not used */ +const char * +TkPixelPrintProc( + ClientData clientData, /* not used */ + Tk_Window tkwin, /* not used */ + char *widgRec, /* Widget structure record */ + int offset, /* Offset of tile in record */ + Tcl_FreeProc **freeProcPtr) /* not used */ { - double *doublePtr = (double *)(widgRec + offset); - char *p; + double *doublePtr = (double *) (widgRec + offset); + char *p = ckalloc(24); - p = (char *) ckalloc(24); - Tcl_PrintDouble((Tcl_Interp *) NULL, *doublePtr, p); + Tcl_PrintDouble(NULL, *doublePtr, p); *freeProcPtr = TCL_DYNAMIC; return p; } @@ -515,31 +521,31 @@ TkPixelPrintProc(clientData, tkwin, widgRec, offset, freeProcPtr) * * TkDrawInsetFocusHighlight -- * - * This procedure draws a rectangular ring around the outside of - * a widget to indicate that it has received the input focus. It - * takes an additional padding argument that specifies how much - * padding is present outside th widget. + * This function draws a rectangular ring around the outside of a widget + * to indicate that it has received the input focus. It takes an + * additional padding argument that specifies how much padding is present + * outside the widget. * * Results: * None. * * Side effects: - * A rectangle "width" pixels wide is drawn in "drawable", - * corresponding to the outer area of "tkwin". + * A rectangle "width" pixels wide is drawn in "drawable", corresponding + * to the outer area of "tkwin". * *---------------------------------------------------------------------- */ void -TkDrawInsetFocusHighlight(tkwin, gc, width, drawable, padding) - Tk_Window tkwin; /* Window whose focus highlight ring is - * to be drawn. */ - GC gc; /* Graphics context to use for drawing - * the highlight ring. */ - int width; /* Width of the highlight ring, in pixels. */ - Drawable drawable; /* Where to draw the ring (typically a - * pixmap for double buffering). */ - int padding; /* Width of padding outside of widget. */ +TkDrawInsetFocusHighlight( + Tk_Window tkwin, /* Window whose focus highlight ring is to be + * drawn. */ + GC gc, /* Graphics context to use for drawing the + * highlight ring. */ + int width, /* Width of the highlight ring, in pixels. */ + Drawable drawable, /* Where to draw the ring (typically a pixmap + * for double buffering). */ + int padding) /* Width of padding outside of widget. */ { XRectangle rects[4]; @@ -567,34 +573,34 @@ TkDrawInsetFocusHighlight(tkwin, gc, width, drawable, padding) * * Tk_DrawFocusHighlight -- * - * This procedure draws a rectangular ring around the outside of - * a widget to indicate that it has received the input focus. + * This function draws a rectangular ring around the outside of a widget + * to indicate that it has received the input focus. * - * This function is now deprecated. Use TkpDrawHighlightBorder instead, - * since this function does not handle drawing the Focus ring properly - * on the Macintosh - you need to know the background GC as well - * as the foreground since the Mac focus ring separated from the widget - * by a 1 pixel border. + * This function is now deprecated. Use TkpDrawHighlightBorder instead, + * since this function does not handle drawing the Focus ring properly on + * the Macintosh - you need to know the background GC as well as the + * foreground since the Mac focus ring separated from the widget by a 1 + * pixel border. * * Results: * None. * * Side effects: - * A rectangle "width" pixels wide is drawn in "drawable", - * corresponding to the outer area of "tkwin". + * A rectangle "width" pixels wide is drawn in "drawable", corresponding + * to the outer area of "tkwin". * *---------------------------------------------------------------------- */ void -Tk_DrawFocusHighlight(tkwin, gc, width, drawable) - Tk_Window tkwin; /* Window whose focus highlight ring is - * to be drawn. */ - GC gc; /* Graphics context to use for drawing - * the highlight ring. */ - int width; /* Width of the highlight ring, in pixels. */ - Drawable drawable; /* Where to draw the ring (typically a - * pixmap for double buffering). */ +Tk_DrawFocusHighlight( + Tk_Window tkwin, /* Window whose focus highlight ring is to be + * drawn. */ + GC gc, /* Graphics context to use for drawing the + * highlight ring. */ + int width, /* Width of the highlight ring, in pixels. */ + Drawable drawable) /* Where to draw the ring (typically a pixmap + * for double buffering). */ { TkDrawInsetFocusHighlight(tkwin, gc, width, drawable, 0); } @@ -604,19 +610,18 @@ Tk_DrawFocusHighlight(tkwin, gc, width, drawable) * * Tk_GetScrollInfo -- * - * This procedure is invoked to parse "xview" and "yview" - * scrolling commands for widgets using the new scrolling - * command syntax ("moveto" or "scroll" options). + * This function is invoked to parse "xview" and "yview" scrolling + * commands for widgets using the new scrolling command syntax ("moveto" + * or "scroll" options). * * Results: * The return value is either TK_SCROLL_MOVETO, TK_SCROLL_PAGES, - * TK_SCROLL_UNITS, or TK_SCROLL_ERROR. This indicates whether - * the command was successfully parsed and what form the command - * took. If TK_SCROLL_MOVETO, *dblPtr is filled in with the - * desired position; if TK_SCROLL_PAGES or TK_SCROLL_UNITS, - * *intPtr is filled in with the number of lines to move (may be - * negative); if TK_SCROLL_ERROR, the interp's result contains an - * error message. + * TK_SCROLL_UNITS, or TK_SCROLL_ERROR. This indicates whether the + * command was successfully parsed and what form the command took. If + * TK_SCROLL_MOVETO, *dblPtr is filled in with the desired position; if + * TK_SCROLL_PAGES or TK_SCROLL_UNITS, *intPtr is filled in with the + * number of lines to move (may be negative); if TK_SCROLL_ERROR, the + * interp's result contains an error message. * * Side effects: * None. @@ -625,25 +630,22 @@ Tk_DrawFocusHighlight(tkwin, gc, width, drawable) */ int -Tk_GetScrollInfo(interp, argc, argv, dblPtr, intPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - int argc; /* # arguments for command. */ - CONST char **argv; /* Arguments for command. */ - double *dblPtr; /* Filled in with argument "moveto" - * option, if any. */ - int *intPtr; /* Filled in with number of pages - * or lines to scroll, if any. */ +Tk_GetScrollInfo( + Tcl_Interp *interp, /* Used for error reporting. */ + int argc, /* # arguments for command. */ + const char **argv, /* Arguments for command. */ + double *dblPtr, /* Filled in with argument "moveto" option, if + * any. */ + int *intPtr) /* Filled in with number of pages or lines to + * scroll, if any. */ { - int c; - size_t length; + int c = argv[2][0]; + size_t length = strlen(argv[2]); - length = strlen(argv[2]); - c = argv[2][0]; if ((c == 'm') && (strncmp(argv[2], "moveto", length) == 0)) { if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " ", argv[1], " moveto fraction\"", - (char *) NULL); + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " moveto fraction\"", NULL); return TK_SCROLL_ERROR; } if (Tcl_GetDouble(interp, argv[3], dblPtr) != TCL_OK) { @@ -653,9 +655,8 @@ Tk_GetScrollInfo(interp, argc, argv, dblPtr, intPtr) } else if ((c == 's') && (strncmp(argv[2], "scroll", length) == 0)) { if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " ", argv[1], " scroll number units|pages\"", - (char *) NULL); + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " scroll number units|pages\"", NULL); return TK_SCROLL_ERROR; } if (Tcl_GetInt(interp, argv[3], intPtr) != TCL_OK) { @@ -665,17 +666,16 @@ Tk_GetScrollInfo(interp, argc, argv, dblPtr, intPtr) c = argv[4][0]; if ((c == 'p') && (strncmp(argv[4], "pages", length) == 0)) { return TK_SCROLL_PAGES; - } else if ((c == 'u') - && (strncmp(argv[4], "units", length) == 0)) { + } else if ((c == 'u') && (strncmp(argv[4], "units", length) == 0)) { return TK_SCROLL_UNITS; - } else { - Tcl_AppendResult(interp, "bad argument \"", argv[4], - "\": must be units or pages", (char *) NULL); - return TK_SCROLL_ERROR; } + + Tcl_AppendResult(interp, "bad argument \"", argv[4], + "\": must be units or pages", NULL); + return TK_SCROLL_ERROR; } Tcl_AppendResult(interp, "unknown option \"", argv[2], - "\": must be moveto or scroll", (char *) NULL); + "\": must be moveto or scroll", NULL); return TK_SCROLL_ERROR; } @@ -684,19 +684,18 @@ Tk_GetScrollInfo(interp, argc, argv, dblPtr, intPtr) * * Tk_GetScrollInfoObj -- * - * This procedure is invoked to parse "xview" and "yview" - * scrolling commands for widgets using the new scrolling - * command syntax ("moveto" or "scroll" options). + * This function is invoked to parse "xview" and "yview" scrolling + * commands for widgets using the new scrolling command syntax ("moveto" + * or "scroll" options). * * Results: * The return value is either TK_SCROLL_MOVETO, TK_SCROLL_PAGES, - * TK_SCROLL_UNITS, or TK_SCROLL_ERROR. This indicates whether - * the command was successfully parsed and what form the command - * took. If TK_SCROLL_MOVETO, *dblPtr is filled in with the - * desired position; if TK_SCROLL_PAGES or TK_SCROLL_UNITS, - * *intPtr is filled in with the number of lines to move (may be - * negative); if TK_SCROLL_ERROR, the interp's result contains an - * error message. + * TK_SCROLL_UNITS, or TK_SCROLL_ERROR. This indicates whether the + * command was successfully parsed and what form the command took. If + * TK_SCROLL_MOVETO, *dblPtr is filled in with the desired position; if + * TK_SCROLL_PAGES or TK_SCROLL_UNITS, *intPtr is filled in with the + * number of lines to move (may be negative); if TK_SCROLL_ERROR, the + * interp's result contains an error message. * * Side effects: * None. @@ -705,23 +704,22 @@ Tk_GetScrollInfo(interp, argc, argv, dblPtr, intPtr) */ int -Tk_GetScrollInfoObj(interp, objc, objv, dblPtr, intPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - int objc; /* # arguments for command. */ - Tcl_Obj *CONST objv[]; /* Arguments for command. */ - double *dblPtr; /* Filled in with argument "moveto" - * option, if any. */ - int *intPtr; /* Filled in with number of pages - * or lines to scroll, if any. */ +Tk_GetScrollInfoObj( + Tcl_Interp *interp, /* Used for error reporting. */ + int objc, /* # arguments for command. */ + Tcl_Obj *const objv[], /* Arguments for command. */ + double *dblPtr, /* Filled in with argument "moveto" option, if + * any. */ + int *intPtr) /* Filled in with number of pages or lines to + * scroll, if any. */ { - int c; - size_t length; - char *arg2, *arg4; + int length; + const char *arg = Tcl_GetStringFromObj(objv[2], &length); - arg2 = Tcl_GetString(objv[2]); - length = strlen(arg2); - c = arg2[0]; - if ((c == 'm') && (strncmp(arg2, "moveto", length) == 0)) { +#define ArgPfxEq(str) \ + ((arg[0] == str[0]) && !strncmp(arg, str, (unsigned)length)) + + if (ArgPfxEq("moveto")) { if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "moveto fraction"); return TK_SCROLL_ERROR; @@ -730,8 +728,7 @@ Tk_GetScrollInfoObj(interp, objc, objv, dblPtr, intPtr) return TK_SCROLL_ERROR; } return TK_SCROLL_MOVETO; - } else if ((c == 's') - && (strncmp(arg2, "scroll", length) == 0)) { + } else if (ArgPfxEq("scroll")) { if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "scroll number units|pages"); return TK_SCROLL_ERROR; @@ -739,22 +736,20 @@ Tk_GetScrollInfoObj(interp, objc, objv, dblPtr, intPtr) if (Tcl_GetIntFromObj(interp, objv[3], intPtr) != TCL_OK) { return TK_SCROLL_ERROR; } - arg4 = Tcl_GetString(objv[4]); - length = (strlen(arg4)); - c = arg4[0]; - if ((c == 'p') && (strncmp(arg4, "pages", length) == 0)) { + + arg = Tcl_GetStringFromObj(objv[4], &length); + if (ArgPfxEq("pages")) { return TK_SCROLL_PAGES; - } else if ((c == 'u') - && (strncmp(arg4, "units", length) == 0)) { + } else if (ArgPfxEq("units")) { return TK_SCROLL_UNITS; - } else { - Tcl_AppendResult(interp, "bad argument \"", arg4, - "\": must be units or pages", (char *) NULL); - return TK_SCROLL_ERROR; } + + Tcl_AppendResult(interp, "bad argument \"", arg, + "\": must be units or pages", NULL); + return TK_SCROLL_ERROR; } - Tcl_AppendResult(interp, "unknown option \"", arg2, - "\": must be moveto or scroll", (char *) NULL); + Tcl_AppendResult(interp, "unknown option \"", arg, + "\": must be moveto or scroll", NULL); return TK_SCROLL_ERROR; } @@ -764,66 +759,80 @@ Tk_GetScrollInfoObj(interp, objc, objv, dblPtr, intPtr) * TkComputeAnchor -- * * Determine where to place a rectangle so that it will be properly - * anchored with respect to the given window. Used by widgets - * to align a box of text inside a window. When anchoring with - * respect to one of the sides, the rectangle be placed inside of - * the internal border of the window. + * anchored with respect to the given window. Used by widgets to align a + * box of text inside a window. When anchoring with respect to one of the + * sides, the rectangle be placed inside of the internal border of the + * window. * * Results: - * *xPtr and *yPtr set to the upper-left corner of the rectangle - * anchored in the window. + * *xPtr and *yPtr set to the upper-left corner of the rectangle anchored + * in the window. * * Side effects: * None. * *--------------------------------------------------------------------------- */ + void -TkComputeAnchor(anchor, tkwin, padX, padY, innerWidth, innerHeight, xPtr, yPtr) - Tk_Anchor anchor; /* Desired anchor. */ - Tk_Window tkwin; /* Anchored with respect to this window. */ - int padX, padY; /* Use this extra padding inside window, in +TkComputeAnchor( + Tk_Anchor anchor, /* Desired anchor. */ + Tk_Window tkwin, /* Anchored with respect to this window. */ + int padX, int padY, /* Use this extra padding inside window, in * addition to the internal border. */ - int innerWidth, innerHeight;/* Size of rectangle to anchor in window. */ - int *xPtr, *yPtr; /* Returns upper-left corner of anchored + int innerWidth, int innerHeight, + /* Size of rectangle to anchor in window. */ + int *xPtr, int *yPtr) /* Returns upper-left corner of anchored * rectangle. */ { - switch (anchor) { - case TK_ANCHOR_NW: - case TK_ANCHOR_W: - case TK_ANCHOR_SW: - *xPtr = Tk_InternalBorderLeft(tkwin) + padX; - break; - - case TK_ANCHOR_N: - case TK_ANCHOR_CENTER: - case TK_ANCHOR_S: - *xPtr = (Tk_Width(tkwin) - innerWidth) / 2; - break; - - default: - *xPtr = Tk_Width(tkwin) - (Tk_InternalBorderRight(tkwin) + padX) - - innerWidth; - break; - } + /* + * Handle the horizontal parts. + */ switch (anchor) { - case TK_ANCHOR_NW: - case TK_ANCHOR_N: - case TK_ANCHOR_NE: - *yPtr = Tk_InternalBorderTop(tkwin) + padY; - break; + case TK_ANCHOR_NW: + case TK_ANCHOR_W: + case TK_ANCHOR_SW: + *xPtr = Tk_InternalBorderLeft(tkwin) + padX; + break; + + case TK_ANCHOR_N: + case TK_ANCHOR_CENTER: + case TK_ANCHOR_S: + *xPtr = (Tk_Width(tkwin) - innerWidth - Tk_InternalBorderLeft(tkwin) - + Tk_InternalBorderRight(tkwin)) / 2 + + Tk_InternalBorderLeft(tkwin); + break; + + default: + *xPtr = Tk_Width(tkwin) - Tk_InternalBorderRight(tkwin) - padX + - innerWidth; + break; + } - case TK_ANCHOR_W: - case TK_ANCHOR_CENTER: - case TK_ANCHOR_E: - *yPtr = (Tk_Height(tkwin) - innerHeight) / 2; - break; + /* + * Handle the vertical parts. + */ - default: - *yPtr = Tk_Height(tkwin) - Tk_InternalBorderBottom(tkwin) - padY - - innerHeight; - break; + switch (anchor) { + case TK_ANCHOR_NW: + case TK_ANCHOR_N: + case TK_ANCHOR_NE: + *yPtr = Tk_InternalBorderTop(tkwin) + padY; + break; + + case TK_ANCHOR_W: + case TK_ANCHOR_CENTER: + case TK_ANCHOR_E: + *yPtr = (Tk_Height(tkwin) - innerHeight- Tk_InternalBorderTop(tkwin) - + Tk_InternalBorderBottom(tkwin)) / 2 + + Tk_InternalBorderTop(tkwin); + break; + + default: + *yPtr = Tk_Height(tkwin) - Tk_InternalBorderBottom(tkwin) - padY + - innerHeight; + break; } } @@ -835,10 +844,9 @@ TkComputeAnchor(anchor, tkwin, padX, padY, innerWidth, innerHeight, xPtr, yPtr) * Given a lookup table, map a number to a string in the table. * * Results: - * If numKey was equal to the numeric key of one of the elements - * in the table, returns the string key of that element. - * Returns NULL if numKey was not equal to any of the numeric keys - * in the table. + * If numKey was equal to the numeric key of one of the elements in the + * table, returns the string key of that element. Returns NULL if numKey + * was not equal to any of the numeric keys in the table. * * Side effects. * None. @@ -846,12 +854,12 @@ TkComputeAnchor(anchor, tkwin, padX, padY, innerWidth, innerHeight, xPtr, yPtr) *--------------------------------------------------------------------------- */ -char * -TkFindStateString(mapPtr, numKey) - CONST TkStateMap *mapPtr; /* The state table. */ - int numKey; /* The key to try to find in the table. */ +const char * +TkFindStateString( + const TkStateMap *mapPtr, /* The state table. */ + int numKey) /* The key to try to find in the table. */ { - for ( ; mapPtr->strKey != NULL; mapPtr++) { + for (; mapPtr->strKey!=NULL ; mapPtr++) { if (numKey == mapPtr->numKey) { return mapPtr->strKey; } @@ -862,17 +870,17 @@ TkFindStateString(mapPtr, numKey) /* *--------------------------------------------------------------------------- * - * TkFindStateNum -- + * TkFindStateNum, TkFindStateNumObj -- * * Given a lookup table, map a string to a number in the table. * * Results: - * If strKey was equal to the string keys of one of the elements - * in the table, returns the numeric key of that element. - * Returns the numKey associated with the last element (the NULL - * string one) in the table if strKey was not equal to any of the - * string keys in the table. In that case, an error message is - * also left in the interp's result (if interp is not NULL). + * If strKey was equal to the string keys of one of the elements in the + * table, returns the numeric key of that element. Returns the numKey + * associated with the last element (the NULL string one) in the table if + * strKey was not equal to any of the string keys in the table. In that + * case, an error message is also left in the interp's result (if interp + * is not NULL). * * Side effects. * None. @@ -881,217 +889,302 @@ TkFindStateString(mapPtr, numKey) */ int -TkFindStateNum(interp, option, mapPtr, strKey) - Tcl_Interp *interp; /* Interp for error reporting. */ - CONST char *option; /* String to use when constructing error. */ - CONST TkStateMap *mapPtr; /* Lookup table. */ - CONST char *strKey; /* String to try to find in lookup table. */ +TkFindStateNum( + Tcl_Interp *interp, /* Interp for error reporting. */ + const char *option, /* String to use when constructing error. */ + const TkStateMap *mapPtr, /* Lookup table. */ + const char *strKey) /* String to try to find in lookup table. */ { - CONST TkStateMap *mPtr; + const TkStateMap *mPtr; + + /* + * See if the value is in the state map. + */ for (mPtr = mapPtr; mPtr->strKey != NULL; mPtr++) { if (strcmp(strKey, mPtr->strKey) == 0) { return mPtr->numKey; } } + + /* + * Not there. Generate an error message (if we can) and return the + * default. + */ + if (interp != NULL) { mPtr = mapPtr; Tcl_AppendResult(interp, "bad ", option, " value \"", strKey, - "\": must be ", mPtr->strKey, (char *) NULL); + "\": must be ", mPtr->strKey, NULL); for (mPtr++; mPtr->strKey != NULL; mPtr++) { - Tcl_AppendResult(interp, - ((mPtr[1].strKey != NULL) ? ", " : ", or "), - mPtr->strKey, (char *) NULL); + Tcl_AppendResult(interp, + ((mPtr[1].strKey != NULL) ? ", " : ", or "), + mPtr->strKey, NULL); } } return mPtr->numKey; } int -TkFindStateNumObj(interp, optionPtr, mapPtr, keyPtr) - Tcl_Interp *interp; /* Interp for error reporting. */ - Tcl_Obj *optionPtr; /* String to use when constructing error. */ - CONST TkStateMap *mapPtr; /* Lookup table. */ - Tcl_Obj *keyPtr; /* String key to find in lookup table. */ +TkFindStateNumObj( + Tcl_Interp *interp, /* Interp for error reporting. */ + Tcl_Obj *optionPtr, /* String to use when constructing error. */ + const TkStateMap *mapPtr, /* Lookup table. */ + Tcl_Obj *keyPtr) /* String key to find in lookup table. */ { - CONST TkStateMap *mPtr; - CONST char *key; - CONST Tcl_ObjType *typePtr; + const TkStateMap *mPtr; + const char *key; + const Tcl_ObjType *typePtr; + + /* + * See if the value is in the object cache. + */ if ((keyPtr->typePtr == &tkStateKeyObjType) - && (keyPtr->internalRep.twoPtrValue.ptr1 == (VOID *) mapPtr)) { - return (int) keyPtr->internalRep.twoPtrValue.ptr2; + && (keyPtr->internalRep.twoPtrValue.ptr1 == mapPtr)) { + return PTR2INT(keyPtr->internalRep.twoPtrValue.ptr2); } + /* + * Not there. Look in the state map. + */ + key = Tcl_GetStringFromObj(keyPtr, NULL); for (mPtr = mapPtr; mPtr->strKey != NULL; mPtr++) { if (strcmp(key, mPtr->strKey) == 0) { typePtr = keyPtr->typePtr; if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { - (*typePtr->freeIntRepProc)(keyPtr); + typePtr->freeIntRepProc(keyPtr); } - keyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) mapPtr; - keyPtr->internalRep.twoPtrValue.ptr2 = (VOID *) mPtr->numKey; - keyPtr->typePtr = &tkStateKeyObjType; + keyPtr->internalRep.twoPtrValue.ptr1 = (void *) mapPtr; + keyPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(mPtr->numKey); + keyPtr->typePtr = &tkStateKeyObjType; return mPtr->numKey; } } + + /* + * Not there either. Generate an error message (if we can) and return the + * default. + */ + if (interp != NULL) { mPtr = mapPtr; - Tcl_AppendResult(interp, "bad ", - Tcl_GetStringFromObj(optionPtr, NULL), " value \"", key, - "\": must be ", mPtr->strKey, (char *) NULL); + Tcl_AppendResult(interp, "bad ", Tcl_GetString(optionPtr), + " value \"", key, "\": must be ", mPtr->strKey, NULL); for (mPtr++; mPtr->strKey != NULL; mPtr++) { - Tcl_AppendResult(interp, - ((mPtr[1].strKey != NULL) ? ", " : ", or "), - mPtr->strKey, (char *) NULL); + Tcl_AppendResult(interp, + ((mPtr[1].strKey != NULL) ? ", " : ", or "), + mPtr->strKey, NULL); } } return mPtr->numKey; } - -/* - * For each exit handler created with a call to TkCreateExitHandler - * there is a structure of the following type: - */ - -typedef struct ExitHandler { - Tcl_ExitProc *proc; /* Procedure to call when process exits. */ - ClientData clientData; /* One word of information to pass to proc. */ - struct ExitHandler *nextPtr;/* Next in list of all exit handlers for - * this application, or NULL for end of list. */ -} ExitHandler; - -/* - * There is both per-process and per-thread exit handlers. - * The first list is controlled by a mutex. The other is in - * thread local storage. - */ - -static ExitHandler *firstExitPtr = NULL; - /* First in list of all exit handlers for - * application. */ -TCL_DECLARE_MUTEX(exitMutex) - + /* - *--------------------------------------------------------------------------- + * ---------------------------------------------------------------------- * - * TkCreateExitHandler -- + * TkBackgroundEvalObjv -- * - * Same as Tcl_CreateExitHandler, but private to Tk. + * Evaluate a command while ensuring that we do not affect the + * interpreters state. This is important when evaluating script + * during background tasks. * * Results: - * None. + * A standard Tcl result code. * - * Side effects. - * Sets a handler with Tcl_CreateExitHandler if this is the first call. + * Side Effects: + * The interpreters variables and code may be modified by the script + * but the result will not be modified. * - *--------------------------------------------------------------------------- + * ---------------------------------------------------------------------- */ -void -TkCreateExitHandler (proc, clientData) - Tcl_ExitProc *proc; /* Procedure to invoke. */ - ClientData clientData; /* Arbitrary value to pass to proc. */ +int +TkBackgroundEvalObjv( + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv, + int flags) { - ExitHandler *exitPtr; - - exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); - exitPtr->proc = proc; - exitPtr->clientData = clientData; - Tcl_MutexLock(&exitMutex); - if (firstExitPtr == NULL) { - Tcl_CreateExitHandler(TkFinalize, NULL); + Tcl_DString errorInfo, errorCode; + Tcl_SavedResult state; + int n, r = TCL_OK; + + Tcl_DStringInit(&errorInfo); + Tcl_DStringInit(&errorCode); + + Tcl_Preserve(interp); + + /* + * Record the state of the interpreter + */ + + Tcl_SaveResult(interp, &state); + Tcl_DStringAppend(&errorInfo, + Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY), -1); + Tcl_DStringAppend(&errorCode, + Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY), -1); + + /* + * Evaluate the command and handle any error. + */ + + for (n = 0; n < objc; ++n) { + Tcl_IncrRefCount(objv[n]); } - exitPtr->nextPtr = firstExitPtr; - firstExitPtr = exitPtr; - Tcl_MutexUnlock(&exitMutex); -} + r = Tcl_EvalObjv(interp, objc, objv, flags); + for (n = 0; n < objc; ++n) { + Tcl_DecrRefCount(objv[n]); + } + if (r == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (background event handler)"); + Tcl_BackgroundException(interp, r); + } + + Tcl_Release(interp); + + /* + * Restore the state of the interpreter + */ + Tcl_SetVar(interp, "errorInfo", + Tcl_DStringValue(&errorInfo), TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "errorCode", + Tcl_DStringValue(&errorCode), TCL_GLOBAL_ONLY); + Tcl_RestoreResult(interp, &state); + + /* + * Clean up references. + */ + + Tcl_DStringFree(&errorInfo); + Tcl_DStringFree(&errorCode); + + return r; +} + /* - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- * - * TkDeleteExitHandler -- + * TkMakeEnsemble -- * - * Same as Tcl_DeleteExitHandler, but private to Tk. + * Create an ensemble from a table of implementation commands. This may + * be called recursively to create sub-ensembles. * * Results: - * None. - * - * Side effects. - * None. + * Handle for the ensemble, or NULL if creation of it fails. * - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -void -TkDeleteExitHandler (proc, clientData) - Tcl_ExitProc *proc; /* Procedure that was previously registered. */ - ClientData clientData; /* Arbitrary value to pass to proc. */ +Tcl_Command +TkMakeEnsemble( + Tcl_Interp *interp, + const char *namespace, + const char *name, + ClientData clientData, + const TkEnsemble map[]) { - ExitHandler *exitPtr, *prevPtr; - - Tcl_MutexLock(&exitMutex); - for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL; - prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) { - if ((exitPtr->proc == proc) - && (exitPtr->clientData == clientData)) { - if (prevPtr == NULL) { - firstExitPtr = exitPtr->nextPtr; - } else { - prevPtr->nextPtr = exitPtr->nextPtr; - } - ckfree((char *) exitPtr); - break; + Tcl_Namespace *namespacePtr = NULL; + Tcl_Command ensemble = NULL; + Tcl_Obj *dictObj = NULL, *nameObj; + Tcl_DString ds; + int i; + + if (map == NULL) { + return NULL; + } + + Tcl_DStringInit(&ds); + + namespacePtr = Tcl_FindNamespace(interp, namespace, NULL, 0); + if (namespacePtr == NULL) { + namespacePtr = Tcl_CreateNamespace(interp, namespace, NULL, NULL); + if (namespacePtr == NULL) { + Tcl_Panic("failed to create namespace \"%s\"", namespace); } } - Tcl_MutexUnlock(&exitMutex); - return; -} + nameObj = Tcl_NewStringObj(name, -1); + ensemble = Tcl_FindEnsemble(interp, nameObj, 0); + Tcl_DecrRefCount(nameObj); + if (ensemble == NULL) { + ensemble = Tcl_CreateEnsemble(interp, name, namespacePtr, + TCL_ENSEMBLE_PREFIX); + if (ensemble == NULL) { + Tcl_Panic("failed to create ensemble \"%s\"", name); + } + } + + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, namespace, -1); + if (!(strlen(namespace) == 2 && namespace[1] == ':')) { + Tcl_DStringAppend(&ds, "::", -1); + } + Tcl_DStringAppend(&ds, name, -1); + + dictObj = Tcl_NewObj(); + for (i = 0; map[i].name != NULL ; ++i) { + Tcl_Obj *nameObj, *fqdnObj; + + nameObj = Tcl_NewStringObj(map[i].name, -1); + fqdnObj = Tcl_NewStringObj(Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_AppendStringsToObj(fqdnObj, "::", map[i].name, NULL); + Tcl_DictObjPut(NULL, dictObj, nameObj, fqdnObj); + if (map[i].proc) { + Tcl_CreateObjCommand(interp, Tcl_GetString(fqdnObj), + map[i].proc, clientData, NULL); + } else if (map[i].subensemble) { + TkMakeEnsemble(interp, Tcl_DStringValue(&ds), + map[i].name, clientData, map[i].subensemble); + } + } + + if (ensemble) { + Tcl_SetEnsembleMappingDict(interp, ensemble, dictObj); + } + + Tcl_DStringFree(&ds); + return ensemble; +} + /* - *--------------------------------------------------------------------------- - * - * TkFinalize -- + *---------------------------------------------------------------------- * - * Runs our private exit handlers and removes itself from Tcl. This is - * benificial should we want to protect from dangling pointers should - * the Tk shared library be unloaded prior to Tcl which can happen on - * windows should the process be forcefully exiting from an exception - * handler. + * TkSendVirtualEvent -- * - * Results: - * None. + * Send a virtual event notification to the specified target window. + * Equivalent to "event generate $target <<$eventName>>" * - * Side effects. - * None. + * Note that we use Tk_QueueWindowEvent, not Tk_HandleEvent, so this + * routine does not reenter the interpreter. * - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ void -TkFinalize (clientData) - ClientData clientData; /* Arbitrary value to pass to proc. */ +TkSendVirtualEvent( + Tk_Window target, + const char *eventName) { - ExitHandler *exitPtr; - - Tcl_DeleteExitHandler(TkFinalize, NULL); - - Tcl_MutexLock(&exitMutex); - for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) { - /* - * Be careful to remove the handler from the list before - * invoking its callback. This protects us against - * double-freeing if the callback should call - * Tcl_DeleteExitHandler on itself. - */ - - firstExitPtr = exitPtr->nextPtr; - Tcl_MutexUnlock(&exitMutex); - (*exitPtr->proc)(exitPtr->clientData); - ckfree((char *) exitPtr); - Tcl_MutexLock(&exitMutex); - } - firstExitPtr = NULL; - Tcl_MutexUnlock(&exitMutex); + union {XEvent general; XVirtualEvent virtual;} event; + + memset(&event, 0, sizeof(event)); + event.general.xany.type = VirtualEvent; + event.general.xany.serial = NextRequest(Tk_Display(target)); + event.general.xany.send_event = False; + event.general.xany.window = Tk_WindowId(target); + event.general.xany.display = Tk_Display(target); + event.virtual.name = Tk_GetUid(eventName); + + Tk_QueueWindowEvent(&event.general, TCL_QUEUE_TAIL); } +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |