diff options
Diffstat (limited to 'generic/tkObj.c')
| -rw-r--r-- | generic/tkObj.c | 659 |
1 files changed, 659 insertions, 0 deletions
diff --git a/generic/tkObj.c b/generic/tkObj.c new file mode 100644 index 0000000..ff2684c --- /dev/null +++ b/generic/tkObj.c @@ -0,0 +1,659 @@ +/* + * tkObj.c -- + * + * This file contains procedures 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. + * + * RCS: @(#) $Id: tkObj.c,v 1.2 1999/04/16 01:51:20 stanton Exp $ + */ + +#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 = (VOID *) (intval); \ + (objPtr)->internalRep.twoPtrValue.ptr2 = 0 + +#define GET_SIMPLEPIXEL(objPtr) \ + ((int) (objPtr)->internalRep.twoPtrValue.ptr1) + +#define SET_COMPLEXPIXEL(objPtr, repPtr) \ + (objPtr)->internalRep.twoPtrValue.ptr1 = 0; \ + (objPtr)->internalRep.twoPtrValue.ptr2 = (VOID *) repPtr + +#define GET_COMPLEXPIXEL(objPtr) \ + ((PixelRep *) (objPtr)->internalRep.twoPtrValue.ptr2) + + +/* + * The following structure is the internal representation for mm objects. + */ + +typedef struct MMRep { + double value; + int units; + Tk_Window tkwin; + double returnValue; +} MMRep; + +/* + * Prototypes for procedures defined later in this file: + */ + +static void DupMMInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static void DupPixelInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static void FreeMMInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); +static void FreePixelInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); +static int SetMMFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static int SetPixelFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static int SetWindowFromAny _ANSI_ARGS_((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-independant settings. + */ + +static 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-independant settings. + */ + +static Tcl_ObjType mmObjType = { + "mm", /* name */ + FreeMMInternalRep, /* freeIntRepProc */ + DupMMInternalRep, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetMMFromAny /* setFromAnyProc */ +}; + +/* + * The following structure defines the implementation of the "window" + * Tcl object. + */ + +static Tcl_ObjType windowObjType = { + "window", /* name */ + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetWindowFromAny /* setFromAnyProc */ +}; + + + +/* + *---------------------------------------------------------------------- + * + * 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(interp, tkwin, objPtr, intPtr) + 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. */ +{ + int result; + double d; + PixelRep *pixelPtr; + static double bias[] = { + 1.0, 10.0, 25.4, 25.4 / 72.0 + }; + + if (objPtr->typePtr != &pixelObjType) { + result = SetPixelFromAny(interp, objPtr); + if (result != TCL_OK) { + return result; + } + } + + if (SIMPLE_PIXELREP(objPtr)) { + *intPtr = GET_SIMPLEPIXEL(objPtr); + } else { + pixelPtr = GET_COMPLEXPIXEL(objPtr); + if (pixelPtr->tkwin != tkwin) { + d = pixelPtr->value; + if (pixelPtr->units >= 0) { + d *= bias[pixelPtr->units] * WidthOfScreen(Tk_Screen(tkwin)); + d /= WidthMMOfScreen(Tk_Screen(tkwin)); + } + if (d < 0) { + pixelPtr->returnValue = (int) (d - 0.5); + } else { + pixelPtr->returnValue = (int) (d + 0.5); + } + pixelPtr->tkwin = tkwin; + } + *intPtr = pixelPtr->returnValue; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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(objPtr) + Tcl_Obj *objPtr; /* Pixel object with internal rep to free. */ +{ + PixelRep *pixelPtr; + + if (!SIMPLE_PIXELREP(objPtr)) { + pixelPtr = GET_COMPLEXPIXEL(objPtr); + ckfree((char *) pixelPtr); + } + SET_SIMPLEPIXEL(objPtr, 0); +} + +/* + *---------------------------------------------------------------------- + * + * 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(srcPtr, copyPtr) + register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + PixelRep *oldPtr, *newPtr; + + copyPtr->typePtr = srcPtr->typePtr; + + if (SIMPLE_PIXELREP(srcPtr)) { + SET_SIMPLEPIXEL(copyPtr, GET_SIMPLEPIXEL(srcPtr)); + } else { + 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); + } +} + +/* + *---------------------------------------------------------------------- + * + * 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(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *typePtr; + char *string, *rest; + double d; + int i, units; + PixelRep *pixelPtr; + + string = Tcl_GetStringFromObj(objPtr, NULL); + + 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 pixels. + */ + + char buf[100]; + + error: + sprintf(buf, "bad screen distance \"%.50s\"", string); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, buf, NULL); + return TCL_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 { + pixelPtr = (PixelRep *) ckalloc(sizeof(PixelRep)); + pixelPtr->value = d; + pixelPtr->units = units; + pixelPtr->tkwin = NULL; + pixelPtr->returnValue = i; + SET_COMPLEXPIXEL(objPtr, pixelPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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(interp, tkwin, objPtr, doublePtr) + 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 double bias[] = { + 10.0, 25.4, 1.0, 25.4 / 72.0 + }; + + if (objPtr->typePtr != &mmObjType) { + result = SetMMFromAny(interp, objPtr); + if (result != TCL_OK) { + return result; + } + } + + mmPtr = (MMRep *) objPtr->internalRep.otherValuePtr; + 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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(objPtr) + Tcl_Obj *objPtr; /* MM object with internal rep to free. */ +{ + ckfree((char *) objPtr->internalRep.otherValuePtr); + objPtr->internalRep.otherValuePtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * 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(srcPtr, copyPtr) + register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + MMRep *oldPtr, *newPtr; + + copyPtr->typePtr = srcPtr->typePtr; + oldPtr = (MMRep *) srcPtr->internalRep.otherValuePtr; + newPtr = (MMRep *) ckalloc(sizeof(MMRep)); + newPtr->value = oldPtr->value; + newPtr->units = oldPtr->units; + newPtr->tkwin = oldPtr->tkwin; + newPtr->returnValue = oldPtr->returnValue; + copyPtr->internalRep.otherValuePtr = (VOID *) newPtr; +} + +/* + *---------------------------------------------------------------------- + * + * 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(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *typePtr; + char *string, *rest; + double d; + int units; + MMRep *mmPtr; + + string = Tcl_GetStringFromObj(objPtr, NULL); + + 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_AppendResult(interp, "bad screen distance \"", string, + "\"", (char *) 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.otherValuePtr = (VOID *) mmPtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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(interp, tkwin, objPtr, windowPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tk_Window tkwin; /* A token to get the main window from. */ + register Tcl_Obj *objPtr; /* The object from which to get boolean. */ + Tk_Window *windowPtr; /* Place to store resulting window. */ +{ + register int result; + Tk_Window lastWindow; + + result = SetWindowFromAny(interp, objPtr); + if (result != TCL_OK) { + return result; + } + + lastWindow = (Tk_Window) objPtr->internalRep.twoPtrValue.ptr1; + if (tkwin != lastWindow) { + Tk_Window foundWindow = Tk_NameToWindow(interp, + Tcl_GetStringFromObj(objPtr, NULL), tkwin); + + if (foundWindow == NULL) { + return TCL_ERROR; + } + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tkwin; + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) foundWindow; + } + *windowPtr = (Tk_Window) objPtr->internalRep.twoPtrValue.ptr2; + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * SetWindowFromAny -- + * + * Attempt to generate a Tk_Window 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 standard window value is stored as "objPtr"s + * internal representation and the type of "objPtr" is set to Tk_Window. + * + *---------------------------------------------------------------------- + */ + +static int +SetWindowFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *typePtr; + + /* + * Free the old internalRep before setting the new one. + */ + + Tcl_GetStringFromObj(objPtr, NULL); + typePtr = objPtr->typePtr; + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + (*typePtr->freeIntRepProc)(objPtr); + } + objPtr->typePtr = &windowObjType; + objPtr->internalRep.twoPtrValue.ptr1 = NULL; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + + return TCL_OK; +} |