--- /dev/null
+/*
+ * tkObj.c --
+ *
+ * This file contains functions that implement the common Tk object types
+ *
+ * Copyright (c) 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.
+ */
+
+#include "tkInt.h"
+
+/*
+ * The following structure is the internal representation for pixel objects.
+ */
+
+typedef struct PixelRep {
+ double value;
+ int units;
+ Tk_Window tkwin;
+ int returnValue;
+} PixelRep;
+
+#define SIMPLE_PIXELREP(objPtr) \
+ ((objPtr)->internalRep.twoPtrValue.ptr2 == 0)
+
+#define SET_SIMPLEPIXEL(objPtr, intval) \
+ (objPtr)->internalRep.twoPtrValue.ptr1 = INT2PTR(intval); \
+ (objPtr)->internalRep.twoPtrValue.ptr2 = 0
+
+#define GET_SIMPLEPIXEL(objPtr) \
+ (PTR2INT((objPtr)->internalRep.twoPtrValue.ptr1))
+
+#define SET_COMPLEXPIXEL(objPtr, repPtr) \
+ (objPtr)->internalRep.twoPtrValue.ptr1 = NULL; \
+ (objPtr)->internalRep.twoPtrValue.ptr2 = repPtr
+
+#define GET_COMPLEXPIXEL(objPtr) \
+ ((PixelRep *) (objPtr)->internalRep.twoPtrValue.ptr2)
+
+/*
+ * One of these structures is created per thread to store thread-specific
+ * data. In this case, it is used to contain references to selected
+ * Tcl_ObjTypes that we can use as screen distances without conversion. The
+ * "dataKey" below is used to locate the ThreadSpecificData for the current
+ * thread.
+ */
+
+typedef struct {
+ const Tcl_ObjType *doubleTypePtr;
+ const Tcl_ObjType *intTypePtr;
+} ThreadSpecificData;
+static Tcl_ThreadDataKey dataKey;
+
+/*
+ * The following structure is the internal representation for mm objects.
+ */
+
+typedef struct MMRep {
+ double value;
+ int units;
+ Tk_Window tkwin;
+ double returnValue;
+} MMRep;
+
+/*
+ * The following structure is the internal representation for window objects.
+ * A WindowRep caches name-to-window lookups. The cache is invalid if tkwin is
+ * NULL or if mainPtr->deletionEpoch does not match epoch.
+ */
+
+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
+ * successful lookup. */
+} WindowRep;
+
+/*
+ * Prototypes for functions defined later in this file:
+ */
+
+static void DupMMInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
+static void DupPixelInternalRep(Tcl_Obj *srcPtr, Tcl_Obj*copyPtr);
+static void DupWindowInternalRep(Tcl_Obj *srcPtr,Tcl_Obj*copyPtr);
+static void FreeMMInternalRep(Tcl_Obj *objPtr);
+static void FreePixelInternalRep(Tcl_Obj *objPtr);
+static void FreeWindowInternalRep(Tcl_Obj *objPtr);
+static ThreadSpecificData *GetTypeCache(void);
+static void UpdateStringOfMM(Tcl_Obj *objPtr);
+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);
+
+/*
+ * 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 */
+ FreePixelInternalRep, /* freeIntRepProc */
+ DupPixelInternalRep, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ SetPixelFromAny /* setFromAnyProc */
+};
+
+/*
+ * 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 */
+ FreeMMInternalRep, /* freeIntRepProc */
+ DupMMInternalRep, /* dupIntRepProc */
+ UpdateStringOfMM, /* updateStringProc */
+ SetMMFromAny /* setFromAnyProc */
+};
+
+/*
+ * The following structure defines the implementation of the "window"
+ * Tcl object.
+ */
+
+static const Tcl_ObjType windowObjType = {
+ "window", /* name */
+ FreeWindowInternalRep, /* freeIntRepProc */
+ DupWindowInternalRep, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ SetWindowFromAny /* setFromAnyProc */
+};
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetTypeCache --
+ *
+ * Get (and build if necessary) the cache of useful Tcl object types for
+ * comparisons in the conversion functions. This allows optimized checks
+ * for standard cases.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static ThreadSpecificData *
+GetTypeCache(void)
+{
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
+ Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
+
+ if (tsdPtr->doubleTypePtr == NULL) {
+ /* Smart initialization of doubleTypePtr/intTypePtr without
+ * hash-table lookup or creating complete Tcl_Obj's */
+ Tcl_Obj obj;
+ obj.length = 3;
+ obj.bytes = (char *)"0.0";
+ obj.typePtr = NULL;
+ Tcl_GetDoubleFromObj(NULL, &obj, &obj.internalRep.doubleValue);
+ tsdPtr->doubleTypePtr = obj.typePtr;
+ obj.bytes += 2;
+ obj.length = 1;
+ obj.typePtr = NULL;
+ Tcl_GetLongFromObj(NULL, &obj, &obj.internalRep.longValue);
+ tsdPtr->intTypePtr = obj.typePtr;
+ }
+ return tsdPtr;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetPixelsFromObjEx --
+ *
+ * Attempt to return a pixel value from the Tcl object "objPtr". If the
+ * object is not already a pixel value, an attempt will be made to
+ * convert it to one.
+ *
+ * Results:
+ * The return value is a standard Tcl object result. If an error occurs
+ * during conversion, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
+ *
+ * Side effects:
+ * If the object is not already a pixel, the conversion will free any old
+ * internal representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static
+int
+GetPixelsFromObjEx(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tk_Window tkwin,
+ Tcl_Obj *objPtr, /* The object from which to get pixels. */
+ int *intPtr,
+ double *dblPtr) /* Places to store resulting pixels. */
+{
+ int result, fresh;
+ double d;
+ PixelRep *pixelPtr;
+ static const double bias[] = {
+ 1.0, 10.0, 25.4, 0.35278 /*25.4 / 72.0*/
+ };
+
+ /*
+ * Special hacks where the type of the object is known to be something
+ * that is just numeric and cannot require distance conversion. This pokes
+ * holes in Tcl's abstractions, but they are just for optimization, not
+ * semantics.
+ */
+
+ if (objPtr->typePtr != &pixelObjType) {
+ ThreadSpecificData *typeCache = GetTypeCache();
+
+ if (objPtr->typePtr == typeCache->doubleTypePtr) {
+ (void) Tcl_GetDoubleFromObj(interp, objPtr, &d);
+ if (dblPtr != NULL) {
+ *dblPtr = d;
+ }
+ *intPtr = (int) (d<0 ? d-0.5 : d+0.5);
+ return TCL_OK;
+ } else if (objPtr->typePtr == typeCache->intTypePtr) {
+ (void) Tcl_GetIntFromObj(interp, objPtr, intPtr);
+ if (dblPtr) {
+ *dblPtr = (double) (*intPtr);
+ }
+ return TCL_OK;
+ }
+ }
+
+ retry:
+ fresh = (objPtr->typePtr != &pixelObjType);
+ if (fresh) {
+ result = SetPixelFromAny(interp, objPtr);
+ if (result != TCL_OK) {
+ return result;
+ }
+ }
+
+ if (SIMPLE_PIXELREP(objPtr)) {
+ *intPtr = GET_SIMPLEPIXEL(objPtr);
+ if (dblPtr) {
+ *dblPtr = (double) (*intPtr);
+ }
+ } else {
+ pixelPtr = GET_COMPLEXPIXEL(objPtr);
+ if ((!fresh) && (pixelPtr->tkwin != tkwin)) {
+ /*
+ * In the case of exo-screen conversions of non-pixels, we force a
+ * recomputation from the string.
+ */
+
+ FreePixelInternalRep(objPtr);
+ goto retry;
+ }
+ if ((pixelPtr->tkwin != tkwin) || dblPtr) {
+ d = pixelPtr->value;
+ if (pixelPtr->units >= 0) {
+ d *= bias[pixelPtr->units] * WidthOfScreen(Tk_Screen(tkwin));
+ d /= WidthMMOfScreen(Tk_Screen(tkwin));
+ }
+ pixelPtr->returnValue = (int) (d<0 ? d-0.5 : d+0.5);
+ pixelPtr->tkwin = tkwin;
+ if (dblPtr) {
+ *dblPtr = d;
+ }
+ }
+ *intPtr = pixelPtr->returnValue;
+ }
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_GetPixelsFromObj --
+ *
+ * Attempt to return a pixel value from the Tcl object "objPtr". If the
+ * object is not already a pixel value, an attempt will be made to
+ * convert it to one.
+ *
+ * Results:
+ * The return value is a standard Tcl object result. If an error occurs
+ * during conversion, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
+ *
+ * Side effects:
+ * If the object is not already a pixel, the conversion will free any old
+ * internal representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tk_GetPixelsFromObj(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tk_Window tkwin,
+ Tcl_Obj *objPtr, /* The object from which to get pixels. */
+ int *intPtr) /* Place to store resulting pixels. */
+{
+ return GetPixelsFromObjEx(interp, tkwin, objPtr, intPtr, NULL);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_GetDoublePixelsFromObj --
+ *
+ * Attempt to return a double pixel value from the Tcl object
+ * "objPtr". If the object is not already a pixel value, an attempt will
+ * be made to convert it to one, the internal unit being pixels.
+ *
+ * Results:
+ * The return value is a standard Tcl object result. If an error occurs
+ * during conversion, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
+ *
+ * Side effects:
+ * If the object is not already a pixel, the conversion will free any old
+ * internal representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tk_GetDoublePixelsFromObj(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tk_Window tkwin,
+ Tcl_Obj *objPtr, /* The object from which to get pixels. */
+ double *doublePtr) /* Place to store resulting pixels. */
+{
+ double d;
+ int result, val;
+
+ result = GetPixelsFromObjEx(interp, tkwin, objPtr, &val, &d);
+ if (result != TCL_OK) {
+ return result;
+ }
+ if (objPtr->typePtr == &pixelObjType && !SIMPLE_PIXELREP(objPtr)) {
+ PixelRep *pixelPtr = GET_COMPLEXPIXEL(objPtr);
+
+ if (pixelPtr->units >= 0) {
+ /*
+ * Internally "shimmer" to pixel units.
+ */
+
+ pixelPtr->units = -1;
+ pixelPtr->value = d;
+ }
+ }
+ *doublePtr = d;
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreePixelInternalRep --
+ *
+ * Deallocate the storage associated with a pixel object's internal
+ * representation.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees objPtr's internal representation and sets objPtr's internalRep
+ * to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreePixelInternalRep(
+ Tcl_Obj *objPtr) /* Pixel object with internal rep to free. */
+{
+ if (!SIMPLE_PIXELREP(objPtr)) {
+ PixelRep *pixelPtr = GET_COMPLEXPIXEL(objPtr);
+
+ ckfree(pixelPtr);
+ }
+ SET_SIMPLEPIXEL(objPtr, 0);
+ objPtr->typePtr = NULL;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupPixelInternalRep --
+ *
+ * Initialize the internal representation of a pixel Tcl_Obj to a copy of
+ * the internal representation of an existing pixel object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * copyPtr's internal rep is set to the pixel corresponding to srcPtr's
+ * internal rep.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupPixelInternalRep(
+ Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
+ Tcl_Obj *copyPtr) /* Object with internal rep to set. */
+{
+ copyPtr->typePtr = srcPtr->typePtr;
+
+ if (SIMPLE_PIXELREP(srcPtr)) {
+ SET_SIMPLEPIXEL(copyPtr, GET_SIMPLEPIXEL(srcPtr));
+ } else {
+ PixelRep *oldPtr, *newPtr;
+
+ oldPtr = GET_COMPLEXPIXEL(srcPtr);
+ newPtr = (PixelRep *)ckalloc(sizeof(PixelRep));
+ newPtr->value = oldPtr->value;
+ newPtr->units = oldPtr->units;
+ newPtr->tkwin = oldPtr->tkwin;
+ newPtr->returnValue = oldPtr->returnValue;
+ SET_COMPLEXPIXEL(copyPtr, newPtr);
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetPixelFromAny --
+ *
+ * Attempt to generate a pixel internal form for the Tcl object "objPtr".
+ *
+ * Results:
+ * The return value is a standard Tcl result. If an error occurs during
+ * conversion, an error message is left in the interpreter's result
+ * unless "interp" is NULL.
+ *
+ * Side effects:
+ * If no error occurs, a pixel representation of the object is stored
+ * internally and the type of "objPtr" is set to pixel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetPixelFromAny(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr) /* The object to convert. */
+{
+ const Tcl_ObjType *typePtr;
+ const char *string;
+ char *rest;
+ double d;
+ int i, units;
+
+ string = Tcl_GetString(objPtr);
+
+ d = strtod(string, &rest);
+ if (rest == string) {
+ goto error;
+ }
+ while ((*rest != '\0') && isspace(UCHAR(*rest))) {
+ rest++;
+ }
+
+ switch (*rest) {
+ case '\0':
+ units = -1;
+ break;
+ case 'm':
+ units = 0;
+ break;
+ case 'c':
+ units = 1;
+ break;
+ case 'i':
+ units = 2;
+ break;
+ case 'p':
+ units = 3;
+ break;
+ default:
+ goto error;
+ }
+
+ /*
+ * Free the old internalRep before setting the new one.
+ */
+
+ typePtr = objPtr->typePtr;
+ if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
+ typePtr->freeIntRepProc(objPtr);
+ }
+
+ objPtr->typePtr = &pixelObjType;
+
+ i = (int) d;
+ if ((units < 0) && (i == d)) {
+ SET_SIMPLEPIXEL(objPtr, i);
+ } else {
+ PixelRep *pixelPtr = (PixelRep *)ckalloc(sizeof(PixelRep));
+
+ pixelPtr->value = d;
+ pixelPtr->units = units;
+ pixelPtr->tkwin = NULL;
+ pixelPtr->returnValue = i;
+ 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_GetMMFromObj --
+ *
+ * Attempt to return an mm value from the Tcl object "objPtr". If the
+ * object is not already an mm value, an attempt will be made to convert
+ * it to one.
+ *
+ * Results:
+ * The return value is a standard Tcl object result. If an error occurs
+ * during conversion, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
+ *
+ * Side effects:
+ * If the object is not already a pixel, the conversion will free any old
+ * internal representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tk_GetMMFromObj(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tk_Window tkwin,
+ Tcl_Obj *objPtr, /* The object from which to get mms. */
+ double *doublePtr) /* Place to store resulting millimeters. */
+{
+ int result;
+ double d;
+ MMRep *mmPtr;
+ static const double bias[] = {
+ 10.0, 25.4, 1.0, 0.35278 /*25.4 / 72.0*/
+ };
+
+ if (objPtr->typePtr != &mmObjType) {
+ result = SetMMFromAny(interp, objPtr);
+ if (result != TCL_OK) {
+ return result;
+ }
+ }
+
+ mmPtr = (MMRep *)objPtr->internalRep.twoPtrValue.ptr1;
+ if (mmPtr->tkwin != tkwin) {
+ d = mmPtr->value;
+ if (mmPtr->units == -1) {
+ d /= WidthOfScreen(Tk_Screen(tkwin));
+ d *= WidthMMOfScreen(Tk_Screen(tkwin));
+ } else {
+ d *= bias[mmPtr->units];
+ }
+ mmPtr->tkwin = tkwin;
+ mmPtr->returnValue = d;
+ }
+ *doublePtr = mmPtr->returnValue;
+
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeMMInternalRep --
+ *
+ * Deallocate the storage associated with a mm object's internal
+ * representation.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees objPtr's internal representation and sets objPtr's internalRep
+ * to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeMMInternalRep(
+ Tcl_Obj *objPtr) /* MM object with internal rep to free. */
+{
+ ckfree(objPtr->internalRep.twoPtrValue.ptr1);
+ objPtr->internalRep.twoPtrValue.ptr1 = NULL;
+ objPtr->typePtr = NULL;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupMMInternalRep --
+ *
+ * Initialize the internal representation of a pixel Tcl_Obj to a copy of
+ * the internal representation of an existing pixel object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * copyPtr's internal rep is set to the pixel corresponding to srcPtr's
+ * internal rep.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupMMInternalRep(
+ Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
+ Tcl_Obj *copyPtr) /* Object with internal rep to set. */
+{
+ MMRep *oldPtr, *newPtr;
+
+ copyPtr->typePtr = srcPtr->typePtr;
+ oldPtr = (MMRep *)srcPtr->internalRep.twoPtrValue.ptr1;
+ newPtr = (MMRep *)ckalloc(sizeof(MMRep));
+ newPtr->value = oldPtr->value;
+ newPtr->units = oldPtr->units;
+ newPtr->tkwin = oldPtr->tkwin;
+ newPtr->returnValue = oldPtr->returnValue;
+ copyPtr->internalRep.twoPtrValue.ptr1 = newPtr;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateStringOfMM --
+ *
+ * Update the string representation for a pixel Tcl_Obj this function is
+ * only called, if the pixel Tcl_Obj has no unit, because with units the
+ * string representation is created by SetMMFromAny
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's string is set to a valid string that results from the
+ * double-to-string conversion.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UpdateStringOfMM(
+ Tcl_Obj *objPtr) /* pixel obj with string rep to update. */
+{
+ MMRep *mmPtr;
+ char buffer[TCL_DOUBLE_SPACE];
+ size_t len;
+
+ mmPtr = (MMRep *)objPtr->internalRep.twoPtrValue.ptr1;
+ /* assert( mmPtr->units == -1 && objPtr->bytes == NULL ); */
+ if ((mmPtr->units != -1) || (objPtr->bytes != NULL)) {
+ Tcl_Panic("UpdateStringOfMM: false precondition");
+ }
+
+ Tcl_PrintDouble(NULL, mmPtr->value, buffer);
+ len = strlen(buffer);
+
+ objPtr->bytes = (char *)ckalloc(len + 1);
+ strcpy(objPtr->bytes, buffer);
+ objPtr->length = len;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetMMFromAny --
+ *
+ * Attempt to generate a mm internal form for the Tcl object "objPtr".
+ *
+ * Results:
+ * The return value is a standard Tcl result. If an error occurs during
+ * conversion, an error message is left in the interpreter's result
+ * unless "interp" is NULL.
+ *
+ * Side effects:
+ * If no error occurs, a mm representation of the object is stored
+ * internally and the type of "objPtr" is set to mm.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetMMFromAny(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr) /* The object to convert. */
+{
+ ThreadSpecificData *typeCache = GetTypeCache();
+ const Tcl_ObjType *typePtr;
+ const char *string;
+ char *rest;
+ double d;
+ int units;
+ MMRep *mmPtr;
+
+ if (objPtr->typePtr == typeCache->doubleTypePtr) {
+ Tcl_GetDoubleFromObj(interp, objPtr, &d);
+ units = -1;
+ } else if (objPtr->typePtr == typeCache->intTypePtr) {
+ Tcl_GetIntFromObj(interp, objPtr, &units);
+ d = (double) units;
+ units = -1;
+
+ /*
+ * In the case of ints, we need to ensure that a valid string exists
+ * in order for int-but-not-string objects to be converted back to
+ * ints again from mm obj types.
+ */
+
+ (void) Tcl_GetString(objPtr);
+ } else {
+ /*
+ * It wasn't a known int or double, so parse it.
+ */
+
+ string = Tcl_GetString(objPtr);
+
+ d = strtod(string, &rest);
+ if (rest == string) {
+ /*
+ * Must copy string before resetting the result in case a caller
+ * is trying to convert the interpreter's result to mms.
+ */
+
+ error:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad screen distance \"%s\"", string));
+ Tcl_SetErrorCode(interp, "TK", "VALUE", "DISTANCE", NULL);
+ return TCL_ERROR;
+ }
+ while ((*rest != '\0') && isspace(UCHAR(*rest))) {
+ rest++;
+ }
+
+ switch (*rest) {
+ case '\0':
+ units = -1;
+ break;
+ case 'c':
+ units = 0;
+ break;
+ case 'i':
+ units = 1;
+ break;
+ case 'm':
+ units = 2;
+ break;
+ case 'p':
+ units = 3;
+ break;
+ default:
+ goto error;
+ }
+ }
+
+ /*
+ * Free the old internalRep before setting the new one.
+ */
+
+ typePtr = objPtr->typePtr;
+ if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
+ typePtr->freeIntRepProc(objPtr);
+ }
+
+ objPtr->typePtr = &mmObjType;
+
+ mmPtr = (MMRep *)ckalloc(sizeof(MMRep));
+ mmPtr->value = d;
+ mmPtr->units = units;
+ mmPtr->tkwin = NULL;
+ mmPtr->returnValue = d;
+
+ objPtr->internalRep.twoPtrValue.ptr1 = mmPtr;
+
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkGetWindowFromObj --
+ *
+ * Attempt to return a Tk_Window from the Tcl object "objPtr". If the
+ * object is not already a Tk_Window, an attempt will be made to convert
+ * it to one.
+ *
+ * Results:
+ * The return value is a standard Tcl object result. If an error occurs
+ * during conversion, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
+ *
+ * Side effects:
+ * If the object is not already a Tk_Window, the conversion will free any
+ * old internal representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TkGetWindowFromObj(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tk_Window tkwin, /* A token to get the main window from. */
+ Tcl_Obj *objPtr, /* The object from which to get window. */
+ Tk_Window *windowPtr) /* Place to store resulting window. */
+{
+ TkMainInfo *mainPtr = ((TkWindow *) tkwin)->mainPtr;
+ WindowRep *winPtr;
+
+ if (objPtr->typePtr != &windowObjType) {
+ int result = SetWindowFromAny(interp, objPtr);
+ if (result != TCL_OK) {
+ return result;
+ }
+ }
+
+ winPtr = (WindowRep *)objPtr->internalRep.twoPtrValue.ptr1;
+ if (winPtr->tkwin == NULL
+ || winPtr->mainPtr == NULL
+ || winPtr->mainPtr != mainPtr
+ || winPtr->epoch != mainPtr->deletionEpoch) {
+ /*
+ * Cache is invalid.
+ */
+
+ winPtr->tkwin = Tk_NameToWindow(interp,
+ Tcl_GetString(objPtr), tkwin);
+ if (winPtr->tkwin == NULL) {
+ /* ASSERT: Tk_NameToWindow has left error message in interp */
+ return TCL_ERROR;
+ }
+
+ winPtr->mainPtr = mainPtr;
+ winPtr->epoch = mainPtr ? mainPtr->deletionEpoch : 0;
+ }
+
+ *windowPtr = winPtr->tkwin;
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetWindowFromAny --
+ *
+ * Generate a windowObj internal form for the Tcl object "objPtr".
+ *
+ * Results:
+ * Always returns TCL_OK.
+ *
+ * Side effects:
+ * Sets objPtr's internal representation to an uninitialized windowObj.
+ * Frees the old internal representation, if any.
+ *
+ * See also:
+ * TkGetWindowFromObj, which initializes the WindowRep cache.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetWindowFromAny(
+ TCL_UNUSED(Tcl_Interp *),
+ Tcl_Obj *objPtr) /* The object to convert. */
+{
+ const Tcl_ObjType *typePtr;
+ WindowRep *winPtr;
+
+ /*
+ * Free the old internalRep before setting the new one.
+ */
+
+ Tcl_GetString(objPtr);
+ typePtr = objPtr->typePtr;
+ if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
+ typePtr->freeIntRepProc(objPtr);
+ }
+
+ winPtr = (WindowRep *)ckalloc(sizeof(WindowRep));
+ winPtr->tkwin = NULL;
+ winPtr->mainPtr = NULL;
+ winPtr->epoch = 0;
+
+ objPtr->internalRep.twoPtrValue.ptr1 = winPtr;
+ objPtr->typePtr = &windowObjType;
+
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupWindowInternalRep --
+ *
+ * Initialize the internal representation of a window Tcl_Obj to a copy
+ * of the internal representation of an existing window object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * copyPtr's internal rep is set to refer to the same window as srcPtr's
+ * internal rep.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupWindowInternalRep(
+ Tcl_Obj *srcPtr,
+ Tcl_Obj *copyPtr)
+{
+ WindowRep *oldPtr, *newPtr;
+
+ oldPtr = (WindowRep *)srcPtr->internalRep.twoPtrValue.ptr1;
+ newPtr = (WindowRep *)ckalloc(sizeof(WindowRep));
+ newPtr->tkwin = oldPtr->tkwin;
+ newPtr->mainPtr = oldPtr->mainPtr;
+ newPtr->epoch = oldPtr->epoch;
+ copyPtr->internalRep.twoPtrValue.ptr1 = newPtr;
+ copyPtr->typePtr = srcPtr->typePtr;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeWindowInternalRep --
+ *
+ * Deallocate the storage associated with a window object's internal
+ * representation.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees objPtr's internal representation and sets objPtr's internalRep
+ * to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeWindowInternalRep(
+ Tcl_Obj *objPtr) /* Window object with internal rep to free. */
+{
+ ckfree(objPtr->internalRep.twoPtrValue.ptr1);
+ objPtr->internalRep.twoPtrValue.ptr1 = NULL;
+ objPtr->typePtr = NULL;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkNewWindowObj --
+ *
+ * This function allocates a new Tcl_Obj that refers to a particular to a
+ * particular Tk window.
+ *
+ * Results:
+ * A standard Tcl object reference, with refcount 0.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TkNewWindowObj(
+ Tk_Window tkwin)
+{
+ Tcl_Obj *objPtr = Tcl_NewStringObj(Tk_PathName(tkwin), -1);
+ TkMainInfo *mainPtr = ((TkWindow *) tkwin)->mainPtr;
+ WindowRep *winPtr;
+
+ SetWindowFromAny(NULL, objPtr);
+
+ winPtr = (WindowRep *)objPtr->internalRep.twoPtrValue.ptr1;
+ winPtr->tkwin = tkwin;
+ winPtr->mainPtr = mainPtr;
+ winPtr->epoch = mainPtr->deletionEpoch;
+ return objPtr;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkParsePadAmount --
+ *
+ * This function parses a padding specification and returns the
+ * appropriate padding values. A padding specification can be either a
+ * single pixel width, or a list of two pixel widths. If a single pixel
+ * width, the amount specified is used for padding on both sides. If two
+ * amounts are specified, then they specify the left/right or top/bottom
+ * padding.
+ *
+ * Results:
+ * A standard Tcl return value.
+ *
+ * Side effects:
+ * An error message is written to the interpreter if something is not
+ * right.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TkParsePadAmount(
+ Tcl_Interp *interp, /* Interpreter for error reporting. */
+ Tk_Window tkwin, /* A window. Needed by Tk_GetPixels() */
+ Tcl_Obj *specObj, /* The argument to "-padx", "-pady", "-ipadx",
+ * or "-ipady". The thing to be parsed. */
+ int *halfPtr, /* Write the left/top part of padding here */
+ 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_Obj **objv; /* The objects in the list */
+
+ /*
+ * Check for a common case where a single object would otherwise be
+ * shimmered between a list and a pixel spec.
+ */
+
+ if (specObj->typePtr == &pixelObjType) {
+ 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);
+ return TCL_ERROR;
+ }
+ secondInt = firstInt;
+ goto done;
+ }
+
+ /*
+ * Pad specifications are a list of one or two elements, each of which is
+ * a pixel specification.
+ */
+
+ if (Tcl_ListObjGetElements(interp, specObj, &objc, &objv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ 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);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse the first part.
+ */
+
+ if (Tk_GetPixelsFromObj(interp, tkwin, objv[0], &firstInt) != TCL_OK ||
+ (firstInt < 0)) {
+ 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);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse the second part if it exists, otherwise it is as if it was the
+ * same as the first part.
+ */
+
+ if (objc == 1) {
+ secondInt = firstInt;
+ } else if (Tk_GetPixelsFromObj(interp, tkwin, objv[1],
+ &secondInt) != TCL_OK || (secondInt < 0)) {
+ 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);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Write the parsed bits back into the receiving variables.
+ */
+
+ done:
+ if (halfPtr != 0) {
+ *halfPtr = firstInt;
+ }
+ *allPtr = firstInt + secondInt;
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkRegisterObjTypes --
+ *
+ * Registers Tk's Tcl_ObjType structures with the Tcl run-time.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * All instances of Tcl_ObjType structures used in Tk are registered with
+ * Tcl.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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);
+}
+\f
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
OSDN Git Service
