diff options
Diffstat (limited to 'generic/tkUtil.c')
| -rw-r--r-- | generic/tkUtil.c | 425 |
1 files changed, 64 insertions, 361 deletions
diff --git a/generic/tkUtil.c b/generic/tkUtil.c index e686826..bfa5d5c 100644 --- a/generic/tkUtil.c +++ b/generic/tkUtil.c @@ -18,7 +18,7 @@ * object, used for quickly finding a mapping in a TkStateMap. */ -const Tcl_ObjType tkStateKeyObjType = { +Tcl_ObjType tkStateKeyObjType = { "statekey", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ @@ -56,11 +56,10 @@ 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; } @@ -85,20 +84,18 @@ TkStateParseProc( return TCL_OK; } - msgObj = Tcl_ObjPrintf("bad %s value \"%s\": must be normal", - ((flags & 4) ? "-default" : "state"), value); - if (flags & 1) { - Tcl_AppendToObj(msgObj, ", active", -1); + Tcl_AppendResult(interp, "bad ", (flags&4)?"-default" : "state", + " value \"", value, "\": must be normal", NULL); + if (flags&1) { + Tcl_AppendResult(interp, ", active", NULL); } - if (flags & 2) { - Tcl_AppendToObj(msgObj, ", hidden", -1); + if (flags&2) { + Tcl_AppendResult(interp, ", hidden", NULL); } - if (flags & 3) { - Tcl_AppendToObj(msgObj, ",", -1); + if (flags&3) { + Tcl_AppendResult(interp, ",", NULL); } - Tcl_AppendToObj(msgObj, " or disabled", -1); - Tcl_SetObjResult(interp, msgObj); - Tcl_SetErrorCode(interp, "TK", "VALUE", "STATE", NULL); + Tcl_AppendResult(interp, " or disabled", NULL); *statePtr = TK_STATE_NORMAL; return TCL_ERROR; } @@ -124,7 +121,7 @@ TkStateParseProc( *-------------------------------------------------------------- */ -const char * +char * TkStatePrintProc( ClientData clientData, /* Ignored. */ Tk_Window tkwin, /* Window containing canvas widget. */ @@ -182,7 +179,7 @@ TkOrientParseProc( register int *orientPtr = (int *) (widgRec + offset); - if (value == NULL || *value == 0) { + if(value == NULL || *value == 0) { *orientPtr = 0; return TCL_OK; } @@ -198,10 +195,8 @@ TkOrientParseProc( *orientPtr = 1; return TCL_OK; } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad orientation \"%s\": must be vertical or horizontal", - value)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "ORIENTATION", NULL); + Tcl_AppendResult(interp, "bad orientation \"", value, + "\": must be vertical or horizontal", NULL); *orientPtr = 0; return TCL_ERROR; } @@ -227,7 +222,7 @@ TkOrientParseProc( *-------------------------------------------------------------- */ -const char * +char * TkOrientPrintProc( ClientData clientData, /* Ignored. */ Tk_Window tkwin, /* Window containing canvas widget. */ @@ -270,7 +265,6 @@ 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; @@ -279,7 +273,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; @@ -342,13 +336,7 @@ TkOffsetParseProc( tsoffset.flags = TK_OFFSET_CENTER|TK_OFFSET_MIDDLE; goto goodTSOffset; } - - /* - * Check for an extra offset. - */ - - q = strchr(p, ','); - if (q == NULL) { + if ((q = strchr(p,',')) == NULL) { if (PTR2INT(clientData) & TK_OFFSET_INDEX) { if (Tcl_GetInt(interp, (char *) p, &tsoffset.flags) != TCL_OK) { Tcl_ResetResult(interp); @@ -359,7 +347,6 @@ TkOffsetParseProc( } goto badTSOffset; } - *((char *) q) = 0; result = Tk_GetPixels(interp, tkwin, (char *) p, &tsoffset.xoffset); *((char *) q) = ','; @@ -370,28 +357,27 @@ 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: - msgObj = Tcl_ObjPrintf("bad offset \"%s\": expected \"x,y\"", value); + Tcl_AppendResult(interp, "bad offset \"", value, + "\": expected \"x,y\"", NULL); if (PTR2INT(clientData) & TK_OFFSET_RELATIVE) { - Tcl_AppendToObj(msgObj, ", \"#x,y\"", -1); + Tcl_AppendResult(interp, ", \"#x,y\"", NULL); } if (PTR2INT(clientData) & TK_OFFSET_INDEX) { - Tcl_AppendToObj(msgObj, ", <index>", -1); + Tcl_AppendResult(interp, ", <index>", 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); + Tcl_AppendResult(interp, ", n, ne, e, se, s, sw, w, nw, or center", NULL); return TCL_ERROR; } @@ -408,7 +394,7 @@ TkOffsetParseProc( *---------------------------------------------------------------------- */ -const char * +char * TkOffsetPrintProc( ClientData clientData, /* not used */ Tk_Window tkwin, /* not used */ @@ -423,7 +409,7 @@ TkOffsetPrintProc( if (offsetPtr->flags >= INT_MAX) { return "end"; } - p = ckalloc(32); + p = (char *) ckalloc(32); sprintf(p, "%d", offsetPtr->flags & ~TK_OFFSET_INDEX); *freeProcPtr = TCL_DYNAMIC; return p; @@ -453,7 +439,7 @@ TkOffsetPrintProc( return "se"; } } - q = p = ckalloc(32); + q = p = (char *) ckalloc(32); if (offsetPtr->flags & TK_OFFSET_RELATIVE) { *q++ = '#'; } @@ -475,7 +461,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 */ @@ -488,9 +474,7 @@ TkPixelParseProc( result = TkGetDoublePixels(interp, tkwin, value, doublePtr); if ((result == TCL_OK) && (clientData == NULL) && (*doublePtr < 0.0)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad screen distance \"%s\"", value)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "PIXELS", NULL); + Tcl_AppendResult(interp, "bad screen distance \"", value, "\"", NULL); return TCL_ERROR; } return result; @@ -509,7 +493,7 @@ TkPixelParseProc( *---------------------------------------------------------------------- */ -const char * +char * TkPixelPrintProc( ClientData clientData, /* not used */ Tk_Window tkwin, /* not used */ @@ -518,7 +502,7 @@ TkPixelPrintProc( Tcl_FreeProc **freeProcPtr) /* not used */ { double *doublePtr = (double *) (widgRec + offset); - char *p = ckalloc(24); + char *p = (char *) ckalloc(24); Tcl_PrintDouble(NULL, *doublePtr, p); *freeProcPtr = TCL_DYNAMIC; @@ -653,10 +637,8 @@ Tk_GetScrollInfo( if ((c == 'm') && (strncmp(argv[2], "moveto", length) == 0)) { if (argc != 4) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "wrong # args: should be \"%s %s %s\"", - argv[0], argv[1], "moveto fraction")); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", 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) { @@ -666,10 +648,8 @@ Tk_GetScrollInfo( } else if ((c == 's') && (strncmp(argv[2], "scroll", length) == 0)) { if (argc != 5) { - 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); + 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) { @@ -683,15 +663,12 @@ Tk_GetScrollInfo( return TK_SCROLL_UNITS; } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad argument \"%s\": must be units or pages", argv[4])); - Tcl_SetErrorCode(interp, "TK", "VALUE", "SCROLL_UNITS", NULL); + Tcl_AppendResult(interp, "bad argument \"", argv[4], + "\": must be units or pages", NULL); return TK_SCROLL_ERROR; } - 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); + Tcl_AppendResult(interp, "unknown option \"", argv[2], + "\": must be moveto or scroll", NULL); return TK_SCROLL_ERROR; } @@ -729,11 +706,12 @@ Tk_GetScrollInfoObj( int *intPtr) /* Filled in with number of pages or lines to * scroll, if any. */ { - const char *arg = Tcl_GetString(objv[2]); - size_t length = objv[2]->length; + int length; + const char *arg; + + 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) { @@ -753,22 +731,19 @@ Tk_GetScrollInfoObj( return TK_SCROLL_ERROR; } - arg = Tcl_GetString(objv[4]); - length = objv[4]->length; + arg = Tcl_GetStringFromObj(objv[4], &length); if (ArgPfxEq("pages")) { return TK_SCROLL_PAGES; } else if (ArgPfxEq("units")) { return TK_SCROLL_UNITS; } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad argument \"%s\": must be units or pages", arg)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "SCROLL_UNITS", NULL); + Tcl_AppendResult(interp, "bad argument \"", arg, + "\": must be units or pages", NULL); return TK_SCROLL_ERROR; } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown option \"%s\": must be moveto or scroll", arg)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", arg, NULL); + Tcl_AppendResult(interp, "unknown option \"", arg, + "\": must be moveto or scroll", NULL); return TK_SCROLL_ERROR; } @@ -873,14 +848,14 @@ TkComputeAnchor( *--------------------------------------------------------------------------- */ -const char * +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 mapPtr->strKey; + return (char *) mapPtr->strKey; } } return NULL; @@ -932,17 +907,14 @@ TkFindStateNum( */ if (interp != NULL) { - Tcl_Obj *msgObj; - mPtr = mapPtr; - msgObj = Tcl_ObjPrintf("bad %s value \"%s\": must be %s", - option, strKey, mPtr->strKey); + Tcl_AppendResult(interp, "bad ", option, " value \"", strKey, + "\": must be ", mPtr->strKey, NULL); for (mPtr++; mPtr->strKey != NULL; mPtr++) { - Tcl_AppendPrintfToObj(msgObj, ",%s %s", - ((mPtr[1].strKey != NULL) ? "" : "or "), mPtr->strKey); + Tcl_AppendResult(interp, + ((mPtr[1].strKey != NULL) ? ", " : ", or "), + mPtr->strKey, NULL); } - Tcl_SetObjResult(interp, msgObj); - Tcl_SetErrorCode(interp, "TK", "LOOKUP", option, strKey, NULL); } return mPtr->numKey; } @@ -971,12 +943,12 @@ TkFindStateNumObj( * Not there. Look in the state map. */ - key = Tcl_GetString(keyPtr); + 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 = INT2PTR(mPtr->numKey); @@ -991,288 +963,19 @@ TkFindStateNumObj( */ if (interp != NULL) { - Tcl_Obj *msgObj; - mPtr = mapPtr; - msgObj = Tcl_ObjPrintf( - "bad %s value \"%s\": must be %s", - Tcl_GetString(optionPtr), key, mPtr->strKey); + Tcl_AppendResult(interp, "bad ", Tcl_GetString(optionPtr), + " value \"", key, "\": must be ", mPtr->strKey, NULL); for (mPtr++; mPtr->strKey != NULL; mPtr++) { - Tcl_AppendPrintfToObj(msgObj, ",%s %s", - ((mPtr[1].strKey != NULL) ? "" : " or"), mPtr->strKey); + Tcl_AppendResult(interp, + ((mPtr[1].strKey != NULL) ? ", " : ", or "), + mPtr->strKey, NULL); } - 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>> -data $detail" - * - * 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, - Tcl_Obj *detail) -{ - 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); - if (detail != NULL) { - event.virtual.user_data = detail; - } - - Tk_QueueWindowEvent(&event.general, TCL_QUEUE_TAIL); -} - -#if TCL_UTF_MAX <= 4 -/* - *--------------------------------------------------------------------------- - * - * TkUtfToUniChar -- - * - * Almost the same as Tcl_UtfToUniChar but using int instead of Tcl_UniChar. - * This function is capable of collapsing a upper/lower surrogate pair to a - * single unicode character. So, up to 6 bytes might be consumed. - * - * Results: - * *chPtr is filled with the Tcl_UniChar, and the return value is the - * number of bytes from the UTF-8 string that were consumed. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -int -TkUtfToUniChar( - const char *src, /* The UTF-8 string. */ - int *chPtr) /* Filled with the Tcl_UniChar represented by - * the UTF-8 string. */ -{ - Tcl_UniChar uniChar = 0; - - int len = Tcl_UtfToUniChar(src, &uniChar); - if ((uniChar & 0xfc00) == 0xd800) { - Tcl_UniChar high = uniChar; - /* This can only happen if Tcl is compiled with TCL_UTF_MAX=4, - * or when a high surrogate character is detected in UTF-8 form */ - int len2 = Tcl_UtfToUniChar(src+len, &uniChar); - if ((uniChar & 0xfc00) == 0xdc00) { - *chPtr = (((high & 0x3ff) << 10) | (uniChar & 0x3ff)) + 0x10000; - len += len2; - } else { - *chPtr = high; - } - } else { - *chPtr = uniChar; - } - return len; -} - -/* - *--------------------------------------------------------------------------- - * - * TkUniCharToUtf -- - * - * Almost the same as Tcl_UniCharToUtf but producing surrogates if - * TCL_UTF_MAX==3. So, up to 6 bytes might be produced. - * - * Results: - * *buf is filled with the UTF-8 string, and the return value is the - * number of bytes produced. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -int TkUniCharToUtf(int ch, char *buf) -{ - int size = Tcl_UniCharToUtf(ch, buf); - if ((ch > 0xffff) && (ch <= 0x10ffff) && (size < 4)) { - /* Hey, this is wrong, we must be running TCL_UTF_MAX==3 - * The best thing we can do is spit out 2 surrogates */ - ch -= 0x10000; - size = Tcl_UniCharToUtf(((ch >> 10) | 0xd800), buf); - size += Tcl_UniCharToUtf(((ch & 0x3ff) | 0xdc00), buf+size); - } - return size; -} - - -#endif -/* * Local Variables: * mode: c * c-basic-offset: 4 |