diff options
Diffstat (limited to 'generic/tkObj.c')
| -rw-r--r-- | generic/tkObj.c | 233 |
1 files changed, 167 insertions, 66 deletions
diff --git a/generic/tkObj.c b/generic/tkObj.c index a184cc6..7239aa2 100644 --- a/generic/tkObj.c +++ b/generic/tkObj.c @@ -3,7 +3,7 @@ * * This file contains functions that implement the common Tk object types * - * Copyright (c) 1997 Sun Microsystems, Inc. + * Copyright © 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. @@ -72,8 +72,12 @@ typedef struct MMRep { typedef struct WindowRep { Tk_Window tkwin; /* Cached window; NULL if not found. */ TkMainInfo *mainPtr; /* MainWindow associated with tkwin. */ - long epoch; /* Value of mainPtr->deletionEpoch at last +#if TCL_MAJOR_VERSION > 8 + size_t epoch; /* Value of mainPtr->deletionEpoch at last * successful lookup. */ +#else + long epoch; +#endif } WindowRep; /* @@ -92,32 +96,72 @@ static int SetMMFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int SetPixelFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int SetWindowFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +#if TCL_MAJOR_VERSION < 9 +#ifdef __cplusplus +extern "C" { +#endif +#if defined(USE_TCL_STUBS) +/* Little hack to eliminate the need for "tclInt.h" here: + Just copy a small portion of TclIntStubs, just + enough to make it work */ +typedef struct TclIntStubs { + int magic; + void *hooks; + void (*dummy[34]) (void); /* dummy entries 0-33, not used */ + int (*tclGetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 34 */ +} TclIntStubs; +extern const TclIntStubs *tclIntStubsPtr; + +# undef Tcl_GetIntForIndex +# define Tcl_GetIntForIndex(interp, obj, max, ptr) ((tclIntStubsPtr->tclGetIntForIndex == NULL)? \ + ((int (*)(Tcl_Interp*, Tcl_Obj *, int, int*))(void *)((&(tclStubsPtr->tcl_PkgProvideEx))[645]))((interp), (obj), (max), (ptr)): \ + tclIntStubsPtr->tclGetIntForIndex((interp), (obj), (max), (ptr))) +#elif TCL_MINOR_VERSION < 7 +extern int TclGetIntForIndex(Tcl_Interp*, Tcl_Obj *, int, int*); +# define Tcl_GetIntForIndex(interp, obj, max, ptr) TclGetIntForIndex(interp, obj, max, ptr) +#endif +#ifdef __cplusplus +} +#endif +#endif + /* * The following structure defines the implementation of the "pixel" Tcl * object, used for measuring distances. The pixel object remembers its * initial display-independent settings. */ -static const Tcl_ObjType pixelObjType = { - "pixel", /* name */ +static const TkObjType pixelObjType = { + {"pixel", /* name */ FreePixelInternalRep, /* freeIntRepProc */ DupPixelInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetPixelFromAny /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V1(TkLengthOne)}, + 0 }; +Tcl_Size +TkLengthOne( + TCL_UNUSED(Tcl_Obj *)) +{ + return 1; +} + /* * The following structure defines the implementation of the "pixel" Tcl * object, used for measuring distances. The pixel object remembers its * initial display-independent settings. */ -static const Tcl_ObjType mmObjType = { - "mm", /* name */ +static const TkObjType mmObjType = { + {"mm", /* name */ FreeMMInternalRep, /* freeIntRepProc */ DupMMInternalRep, /* dupIntRepProc */ UpdateStringOfMM, /* updateStringProc */ - SetMMFromAny /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V1(TkLengthOne)}, + 0 }; /* @@ -125,12 +169,14 @@ static const Tcl_ObjType mmObjType = { * Tcl object. */ -static const Tcl_ObjType windowObjType = { - "window", /* name */ +static const TkObjType windowObjType = { + {"window", /* name */ FreeWindowInternalRep, /* freeIntRepProc */ DupWindowInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetWindowFromAny /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0}, + 0 }; /* @@ -167,6 +213,46 @@ GetTypeCache(void) /* *---------------------------------------------------------------------- * + * TkGetIntForIndex -- + * + * Almost the same as Tcl_GetIntForIndex, but it retrieves an int. Accepts + * "" (empty string) as well. + * + * Results: + * The return value is a standard Tcl object result. + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +TkGetIntForIndex( + Tcl_Obj *indexObj, + Tcl_Size end, + int lastOK, + Tcl_Size *indexPtr) +{ + if (indexObj == NULL) { + *indexPtr = TCL_INDEX_NONE; + return TCL_OK; + } + if (Tcl_GetIntForIndex(NULL, indexObj, end + lastOK, indexPtr) != TCL_OK) { + const char *value = Tcl_GetString(indexObj); + if (!*value) { + /* empty string */ + *indexPtr = (end == -1) ? -1 - TCL_SIZE_MAX : TCL_INDEX_NONE; + return TCL_OK; + } + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * GetPixelsFromObjEx -- * * Attempt to return a pixel value from the Tcl object "objPtr". If the @@ -201,7 +287,7 @@ GetPixelsFromObjEx( 1.0, 10.0, 25.4, 0.35277777777777775 /*25.4 / 72.0*/ }; - if (objPtr->typePtr != &pixelObjType) { + if (objPtr->typePtr != &pixelObjType.objType) { if (Tcl_GetDoubleFromObj(NULL, objPtr, &d) == TCL_OK) { if (dblPtr != NULL) { @@ -213,7 +299,7 @@ GetPixelsFromObjEx( } retry: - fresh = (objPtr->typePtr != &pixelObjType); + fresh = (objPtr->typePtr != &pixelObjType.objType); if (fresh) { result = SetPixelFromAny(interp, objPtr); if (result != TCL_OK) { @@ -320,7 +406,7 @@ Tk_GetDoublePixelsFromObj( if (result != TCL_OK) { return result; } - if (objPtr->typePtr == &pixelObjType && !SIMPLE_PIXELREP(objPtr)) { + if (objPtr->typePtr == &pixelObjType.objType && !SIMPLE_PIXELREP(objPtr)) { PixelRep *pixelPtr = GET_COMPLEXPIXEL(objPtr); if (pixelPtr->units >= 0) { @@ -433,7 +519,7 @@ SetPixelFromAny( { ThreadSpecificData *typeCache = GetTypeCache(); const Tcl_ObjType *typePtr; - const char *string; + char *string; char *rest; double d; int i, units; @@ -453,20 +539,27 @@ SetPixelFromAny( } else if (Tcl_GetDoubleFromObj(NULL, objPtr, &d) == TCL_OK) { units = -1; } else { + char savechar; string = Tcl_GetString(objPtr); - d = strtod(string, &rest); - if (rest == string) { - goto error; + rest = string + strlen(string); + while ((rest > string) && isspace(UCHAR(rest[-1]))) { + --rest; /* skip all spaces at the end */ } - while ((*rest != '\0') && isspace(UCHAR(*rest))) { - rest++; + if (rest > string) { + --rest; /* point to the character just before the last space */ + } + if (rest == string) { + error: + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected screen distance but got \"%.50s\"", string)); + Tcl_SetErrorCode(interp, "TK", "VALUE", "PIXELS", (char *)NULL); + } + return TCL_ERROR; } switch (*rest) { - case '\0': - units = -1; - break; case 'm': units = 0; break; @@ -482,7 +575,15 @@ SetPixelFromAny( default: goto error; } + savechar = *rest; + *rest = '\0'; + if (Tcl_GetDouble(NULL, string, &d) != TCL_OK) { + *rest = savechar; + goto error; + } + *rest = savechar; } + /* * Free the old internalRep before setting the new one. */ @@ -492,7 +593,7 @@ SetPixelFromAny( typePtr->freeIntRepProc(objPtr); } - objPtr->typePtr = &pixelObjType; + objPtr->typePtr = &pixelObjType.objType; i = (int) d; if ((units < 0) && (i == d)) { @@ -507,14 +608,6 @@ SetPixelFromAny( SET_COMPLEXPIXEL(objPtr, pixelPtr); } return TCL_OK; - - error: - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad screen distance \"%.50s\"", string)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "PIXELS", NULL); - } - return TCL_ERROR; } /* @@ -552,7 +645,7 @@ Tk_GetMMFromObj( 10.0, 25.4, 1.0, 0.35277777777777775 /*25.4 / 72.0*/ }; - if (objPtr->typePtr != &mmObjType) { + if (objPtr->typePtr != &mmObjType.objType) { result = SetMMFromAny(interp, objPtr); if (result != TCL_OK) { return result; @@ -726,28 +819,29 @@ SetMMFromAny( } else if (Tcl_GetDoubleFromObj(NULL, objPtr, &d) == TCL_OK) { units = -1; } else { + char savechar; + /* * It wasn't a known int or double, so parse it. */ string = Tcl_GetString(objPtr); - d = strtod(string, &rest); + rest = string + strlen(string); + while ((rest > string) && isspace(UCHAR(rest[-1]))) { + --rest; /* skip all spaces at the end */ + } + if (rest > string) { + --rest; /* point to the character just before the last space */ + } if (rest == string) { error: Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad screen distance \"%s\"", string)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "DISTANCE", NULL); + "expected screen distance but got \"%.50s\"", string)); + Tcl_SetErrorCode(interp, "TK", "VALUE", "PIXELS", (char *)NULL); return TCL_ERROR; } - while ((*rest != '\0') && isspace(UCHAR(*rest))) { - rest++; - } - switch (*rest) { - case '\0': - units = -1; - break; case 'c': units = 0; break; @@ -763,6 +857,13 @@ SetMMFromAny( default: goto error; } + savechar = *rest; + *rest = '\0'; + if (Tcl_GetDouble(NULL, string, &d) != TCL_OK) { + *rest = savechar; + goto error; + } + *rest = savechar; } /* @@ -774,7 +875,7 @@ SetMMFromAny( typePtr->freeIntRepProc(objPtr); } - objPtr->typePtr = &mmObjType; + objPtr->typePtr = &mmObjType.objType; mmPtr = (MMRep *)ckalloc(sizeof(MMRep)); mmPtr->value = d; @@ -818,7 +919,7 @@ TkGetWindowFromObj( TkMainInfo *mainPtr = ((TkWindow *) tkwin)->mainPtr; WindowRep *winPtr; - if (objPtr->typePtr != &windowObjType) { + if (objPtr->typePtr != &windowObjType.objType) { int result = SetWindowFromAny(interp, objPtr); if (result != TCL_OK) { return result; @@ -893,7 +994,7 @@ SetWindowFromAny( winPtr->epoch = 0; objPtr->internalRep.twoPtrValue.ptr1 = winPtr; - objPtr->typePtr = &windowObjType; + objPtr->typePtr = &windowObjType.objType; return TCL_OK; } @@ -962,7 +1063,7 @@ FreeWindowInternalRep( /* *---------------------------------------------------------------------- * - * TkNewWindowObj -- + * Tk_NewWindowObj -- * * This function allocates a new Tcl_Obj that refers to a particular * Tk window. @@ -977,10 +1078,10 @@ FreeWindowInternalRep( */ Tcl_Obj * -TkNewWindowObj( +Tk_NewWindowObj( Tk_Window tkwin) { - Tcl_Obj *objPtr = Tcl_NewStringObj(Tk_PathName(tkwin), -1); + Tcl_Obj *objPtr = Tcl_NewStringObj(Tk_PathName(tkwin), TCL_INDEX_NONE); TkMainInfo *mainPtr = ((TkWindow *) tkwin)->mainPtr; WindowRep *winPtr; @@ -1025,7 +1126,7 @@ TkParsePadAmount( int *allPtr) /* Write the total padding here */ { int firstInt, secondInt; /* The two components of the padding */ - int objc; /* The length of the list (should be 1 or 2) */ + Tcl_Size objc; /* The length of the list (should be 1 or 2) */ Tcl_Obj **objv; /* The objects in the list */ /* @@ -1033,12 +1134,12 @@ TkParsePadAmount( * shimmered between a list and a pixel spec. */ - if (specObj->typePtr == &pixelObjType) { + if (specObj->typePtr == &pixelObjType.objType) { if (Tk_GetPixelsFromObj(interp, tkwin, specObj, &firstInt) != TCL_OK){ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad pad value \"%s\": must be positive screen distance", Tcl_GetString(specObj))); - Tcl_SetErrorCode(interp, "TK", "VALUE", "PADDING", "DIST", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "PADDING", "DIST", (char *)NULL); return TCL_ERROR; } secondInt = firstInt; @@ -1055,8 +1156,8 @@ TkParsePadAmount( } if (objc != 1 && objc != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "wrong number of parts to pad specification", -1)); - Tcl_SetErrorCode(interp, "TK", "VALUE", "PADDING", "PARTS", NULL); + "wrong number of parts to pad specification", TCL_INDEX_NONE)); + Tcl_SetErrorCode(interp, "TK", "VALUE", "PADDING", "PARTS", (char *)NULL); return TCL_ERROR; } @@ -1069,7 +1170,7 @@ TkParsePadAmount( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad pad value \"%s\": must be positive screen distance", Tcl_GetString(objv[0]))); - Tcl_SetErrorCode(interp, "TK", "VALUE", "PADDING", "DIST", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "PADDING", "DIST", (char *)NULL); return TCL_ERROR; } @@ -1085,7 +1186,7 @@ TkParsePadAmount( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad 2nd pad value \"%s\": must be positive screen distance", Tcl_GetString(objv[1]))); - Tcl_SetErrorCode(interp, "TK", "VALUE", "PADDING", "DIST", NULL); + Tcl_SetErrorCode(interp, "TK", "VALUE", "PADDING", "DIST", (char *)NULL); return TCL_ERROR; } @@ -1121,16 +1222,16 @@ TkParsePadAmount( void TkRegisterObjTypes(void) { - Tcl_RegisterObjType(&tkBorderObjType); - Tcl_RegisterObjType(&tkBitmapObjType); - Tcl_RegisterObjType(&tkColorObjType); - Tcl_RegisterObjType(&tkCursorObjType); - Tcl_RegisterObjType(&tkFontObjType); - Tcl_RegisterObjType(&mmObjType); - Tcl_RegisterObjType(&pixelObjType); - Tcl_RegisterObjType(&tkStateKeyObjType); - Tcl_RegisterObjType(&windowObjType); - Tcl_RegisterObjType(&tkTextIndexType); + Tcl_RegisterObjType(&tkBorderObjType.objType); + Tcl_RegisterObjType(&tkBitmapObjType.objType); + Tcl_RegisterObjType(&tkColorObjType.objType); + Tcl_RegisterObjType(&tkCursorObjType.objType); + Tcl_RegisterObjType(&tkFontObjType.objType); + Tcl_RegisterObjType(&mmObjType.objType); + Tcl_RegisterObjType(&pixelObjType.objType); + Tcl_RegisterObjType(&tkStateKeyObjType.objType); + Tcl_RegisterObjType(&windowObjType.objType); + Tcl_RegisterObjType(&tkTextIndexType.objType); } /* |