/*
* 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;
}