diff options
Diffstat (limited to 'generic/tkUtil.c')
| -rw-r--r-- | generic/tkUtil.c | 335 |
1 files changed, 273 insertions, 62 deletions
diff --git a/generic/tkUtil.c b/generic/tkUtil.c index bfa5d5c..0290c94 100644 --- a/generic/tkUtil.c +++ b/generic/tkUtil.c @@ -18,7 +18,7 @@ * object, used for quickly finding a mapping in a TkStateMap. */ -Tcl_ObjType tkStateKeyObjType = { +const Tcl_ObjType tkStateKeyObjType = { "statekey", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ @@ -56,10 +56,11 @@ TkStateParseProc( int c; int flags = PTR2INT(clientData); size_t length; + Tcl_Obj *msgObj; 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; } @@ -84,18 +85,20 @@ TkStateParseProc( return TCL_OK; } - Tcl_AppendResult(interp, "bad ", (flags&4)?"-default" : "state", - " value \"", value, "\": must be normal", NULL); - if (flags&1) { - Tcl_AppendResult(interp, ", active", NULL); + msgObj = Tcl_ObjPrintf("bad %s value \"%s\": must be normal", + ((flags & 4) ? "-default" : "state"), value); + if (flags & 1) { + Tcl_AppendToObj(msgObj, ", active", -1); } - if (flags&2) { - Tcl_AppendResult(interp, ", hidden", NULL); + if (flags & 2) { + Tcl_AppendToObj(msgObj, ", hidden", -1); } - if (flags&3) { - Tcl_AppendResult(interp, ",", NULL); + if (flags & 3) { + Tcl_AppendToObj(msgObj, ",", -1); } - Tcl_AppendResult(interp, " or disabled", NULL); + Tcl_AppendToObj(msgObj, " or disabled", -1); + Tcl_SetObjResult(interp, msgObj); + Tcl_SetErrorCode(interp, "TK", "VALUE", "STATE", NULL); *statePtr = TK_STATE_NORMAL; return TCL_ERROR; } @@ -121,7 +124,7 @@ TkStateParseProc( *-------------------------------------------------------------- */ -char * +const char * TkStatePrintProc( ClientData clientData, /* Ignored. */ Tk_Window tkwin, /* Window containing canvas widget. */ @@ -179,7 +182,7 @@ TkOrientParseProc( register int *orientPtr = (int *) (widgRec + offset); - if(value == NULL || *value == 0) { + if (value == NULL || *value == 0) { *orientPtr = 0; return TCL_OK; } @@ -195,8 +198,10 @@ TkOrientParseProc( *orientPtr = 1; return TCL_OK; } - Tcl_AppendResult(interp, "bad orientation \"", value, - "\": must be vertical or horizontal", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad orientation \"%s\": must be vertical or horizontal", + value)); + Tcl_SetErrorCode(interp, "TK", "VALUE", "ORIENTATION", NULL); *orientPtr = 0; return TCL_ERROR; } @@ -222,7 +227,7 @@ TkOrientParseProc( *-------------------------------------------------------------- */ -char * +const char * TkOrientPrintProc( ClientData clientData, /* Ignored. */ Tk_Window tkwin, /* Window containing canvas widget. */ @@ -265,6 +270,7 @@ TkOffsetParseProc( Tk_TSOffset tsoffset; const char *q, *p; int result; + Tcl_Obj *msgObj; if ((value == NULL) || (*value == 0)) { tsoffset.flags = TK_OFFSET_CENTER|TK_OFFSET_MIDDLE; @@ -273,7 +279,7 @@ TkOffsetParseProc( tsoffset.flags = 0; p = value; - switch(value[0]) { + switch (value[0]) { case '#': if (PTR2INT(clientData) & TK_OFFSET_RELATIVE) { tsoffset.flags = TK_OFFSET_RELATIVE; @@ -336,7 +342,13 @@ TkOffsetParseProc( tsoffset.flags = TK_OFFSET_CENTER|TK_OFFSET_MIDDLE; goto goodTSOffset; } - if ((q = strchr(p,',')) == NULL) { + + /* + * 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); @@ -347,6 +359,7 @@ TkOffsetParseProc( } goto badTSOffset; } + *((char *) q) = 0; result = Tk_GetPixels(interp, tkwin, (char *) p, &tsoffset.xoffset); *((char *) q) = ','; @@ -357,27 +370,28 @@ TkOffsetParseProc( 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()!!!!; + * already created, we must do it with Tk_GetTile()!!!! */ + goodTSOffset: memcpy(offsetPtr, &tsoffset, sizeof(Tk_TSOffset)); return TCL_OK; badTSOffset: - Tcl_AppendResult(interp, "bad offset \"", value, - "\": expected \"x,y\"", NULL); + msgObj = Tcl_ObjPrintf("bad offset \"%s\": expected \"x,y\"", value); if (PTR2INT(clientData) & TK_OFFSET_RELATIVE) { - Tcl_AppendResult(interp, ", \"#x,y\"", NULL); + Tcl_AppendToObj(msgObj, ", \"#x,y\"", -1); } if (PTR2INT(clientData) & TK_OFFSET_INDEX) { - Tcl_AppendResult(interp, ", <index>", NULL); + Tcl_AppendToObj(msgObj, ", <index>", -1); } - Tcl_AppendResult(interp, ", n, ne, e, se, s, sw, w, nw, or center", NULL); + Tcl_AppendToObj(msgObj, ", n, ne, e, se, s, sw, w, nw, or center", -1); + Tcl_SetObjResult(interp, msgObj); + Tcl_SetErrorCode(interp, "TK", "VALUE", "OFFSET", NULL); return TCL_ERROR; } @@ -394,7 +408,7 @@ TkOffsetParseProc( *---------------------------------------------------------------------- */ -char * +const char * TkOffsetPrintProc( ClientData clientData, /* not used */ Tk_Window tkwin, /* not used */ @@ -409,7 +423,7 @@ TkOffsetPrintProc( if (offsetPtr->flags >= INT_MAX) { return "end"; } - p = (char *) ckalloc(32); + p = ckalloc(32); sprintf(p, "%d", offsetPtr->flags & ~TK_OFFSET_INDEX); *freeProcPtr = TCL_DYNAMIC; return p; @@ -439,7 +453,7 @@ TkOffsetPrintProc( return "se"; } } - q = p = (char *) ckalloc(32); + q = p = ckalloc(32); if (offsetPtr->flags & TK_OFFSET_RELATIVE) { *q++ = '#'; } @@ -461,7 +475,7 @@ TkOffsetPrintProc( int TkPixelParseProc( ClientData clientData, /* If non-NULL, negative values are allowed as - * well */ + * 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 */ @@ -474,7 +488,9 @@ TkPixelParseProc( result = TkGetDoublePixels(interp, tkwin, value, doublePtr); if ((result == TCL_OK) && (clientData == NULL) && (*doublePtr < 0.0)) { - Tcl_AppendResult(interp, "bad screen distance \"", value, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad screen distance \"%s\"", value)); + Tcl_SetErrorCode(interp, "TK", "VALUE", "PIXELS", NULL); return TCL_ERROR; } return result; @@ -493,7 +509,7 @@ TkPixelParseProc( *---------------------------------------------------------------------- */ -char * +const char * TkPixelPrintProc( ClientData clientData, /* not used */ Tk_Window tkwin, /* not used */ @@ -502,7 +518,7 @@ TkPixelPrintProc( Tcl_FreeProc **freeProcPtr) /* not used */ { double *doublePtr = (double *) (widgRec + offset); - char *p = (char *) ckalloc(24); + char *p = ckalloc(24); Tcl_PrintDouble(NULL, *doublePtr, p); *freeProcPtr = TCL_DYNAMIC; @@ -637,8 +653,10 @@ Tk_GetScrollInfo( 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\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s %s %s\"", + argv[0], argv[1], "moveto fraction")); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); return TK_SCROLL_ERROR; } if (Tcl_GetDouble(interp, argv[3], dblPtr) != TCL_OK) { @@ -648,8 +666,10 @@ Tk_GetScrollInfo( } 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\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"%s %s %s\"", + argv[0], argv[1], "scroll number units|pages")); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); return TK_SCROLL_ERROR; } if (Tcl_GetInt(interp, argv[3], intPtr) != TCL_OK) { @@ -663,12 +683,15 @@ Tk_GetScrollInfo( return TK_SCROLL_UNITS; } - Tcl_AppendResult(interp, "bad argument \"", argv[4], - "\": must be units or pages", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad argument \"%s\": must be units or pages", argv[4])); + 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_SetObjResult(interp, Tcl_ObjPrintf( + "unknown option \"%s\": must be moveto or scroll", argv[2])); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", argv[2], + NULL); return TK_SCROLL_ERROR; } @@ -707,11 +730,10 @@ Tk_GetScrollInfoObj( * scroll, if any. */ { int length; - const char *arg; - - arg = Tcl_GetStringFromObj(objv[2], &length); + const char *arg = Tcl_GetStringFromObj(objv[2], &length); -#define ArgPfxEq(str) ((arg[0]==str[0])&&!strncmp(arg,str,(unsigned)length)) +#define ArgPfxEq(str) \ + ((arg[0] == str[0]) && !strncmp(arg, str, (unsigned)length)) if (ArgPfxEq("moveto")) { if (objc != 4) { @@ -738,12 +760,14 @@ Tk_GetScrollInfoObj( return TK_SCROLL_UNITS; } - Tcl_AppendResult(interp, "bad argument \"", arg, - "\": must be units or pages", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad argument \"%s\": must be units or pages", arg)); + 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_SetObjResult(interp, Tcl_ObjPrintf( + "unknown option \"%s\": must be moveto or scroll", arg)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", arg, NULL); return TK_SCROLL_ERROR; } @@ -848,14 +872,14 @@ TkComputeAnchor( *--------------------------------------------------------------------------- */ -char * +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++) { if (numKey == mapPtr->numKey) { - return (char *) mapPtr->strKey; + return mapPtr->strKey; } } return NULL; @@ -907,14 +931,17 @@ TkFindStateNum( */ if (interp != NULL) { + Tcl_Obj *msgObj; + mPtr = mapPtr; - Tcl_AppendResult(interp, "bad ", option, " value \"", strKey, - "\": must be ", mPtr->strKey, NULL); + msgObj = Tcl_ObjPrintf("bad %s value \"%s\": must be %s", + option, strKey, mPtr->strKey); for (mPtr++; mPtr->strKey != NULL; mPtr++) { - Tcl_AppendResult(interp, - ((mPtr[1].strKey != NULL) ? ", " : ", or "), - mPtr->strKey, NULL); + Tcl_AppendPrintfToObj(msgObj, ",%s %s", + ((mPtr[1].strKey != NULL) ? "" : "or "), mPtr->strKey); } + Tcl_SetObjResult(interp, msgObj); + Tcl_SetErrorCode(interp, "TK", "LOOKUP", option, strKey, NULL); } return mPtr->numKey; } @@ -943,12 +970,12 @@ TkFindStateNumObj( * Not there. Look in the state map. */ - key = Tcl_GetStringFromObj(keyPtr, NULL); + key = Tcl_GetString(keyPtr); 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 = INT2PTR(mPtr->numKey); @@ -963,19 +990,203 @@ TkFindStateNumObj( */ if (interp != NULL) { + Tcl_Obj *msgObj; + mPtr = mapPtr; - Tcl_AppendResult(interp, "bad ", Tcl_GetString(optionPtr), - " value \"", key, "\": must be ", mPtr->strKey, NULL); + msgObj = Tcl_ObjPrintf( + "bad %s value \"%s\": must be %s", + Tcl_GetString(optionPtr), key, mPtr->strKey); for (mPtr++; mPtr->strKey != NULL; mPtr++) { - Tcl_AppendResult(interp, - ((mPtr[1].strKey != NULL) ? ", " : ", or "), - mPtr->strKey, NULL); + Tcl_AppendPrintfToObj(msgObj, ",%s %s", + ((mPtr[1].strKey != NULL) ? "" : " or"), mPtr->strKey); } + Tcl_SetObjResult(interp, msgObj); + Tcl_SetErrorCode(interp, "TK", "LOOKUP", Tcl_GetString(optionPtr), + key, NULL); } return mPtr->numKey; } /* + * ---------------------------------------------------------------------- + * + * TkBackgroundEvalObjv -- + * + * Evaluate a command while ensuring that we do not affect the + * interpreters state. This is important when evaluating script + * during background tasks. + * + * Results: + * A standard Tcl result code. + * + * Side Effects: + * The interpreters variables and code may be modified by the script + * but the result will not be modified. + * + * ---------------------------------------------------------------------- + */ + +int +TkBackgroundEvalObjv( + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv, + int flags) +{ + Tcl_InterpState state; + int n, r = TCL_OK; + + /* + * Record the state of the interpreter. + */ + + Tcl_Preserve(interp); + state = Tcl_SaveInterpState(interp, TCL_OK); + + /* + * Evaluate the command and handle any error. + */ + + for (n = 0; n < objc; ++n) { + Tcl_IncrRefCount(objv[n]); + } + 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); + } + + /* + * Restore the state of the interpreter. + */ + + (void) Tcl_RestoreInterpState(interp, state); + Tcl_Release(interp); + + return r; +} + +/* + *---------------------------------------------------------------------- + * + * TkMakeEnsemble -- + * + * Create an ensemble from a table of implementation commands. This may + * be called recursively to create sub-ensembles. + * + * Results: + * Handle for the ensemble, or NULL if creation of it fails. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +TkMakeEnsemble( + Tcl_Interp *interp, + const char *namespace, + const char *name, + ClientData clientData, + const TkEnsemble map[]) +{ + 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); + } + } + + 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; +} + +/* + *---------------------------------------------------------------------- + * + * TkSendVirtualEvent -- + * + * Send a virtual event notification to the specified target window. + * Equivalent to "event generate $target <<$eventName>>" + * + * Note that we use Tk_QueueWindowEvent, not Tk_HandleEvent, so this + * routine does not reenter the interpreter. + * + *---------------------------------------------------------------------- + */ + +void +TkSendVirtualEvent( + Tk_Window target, + const char *eventName) +{ + 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 |