Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Tree: 64fcde3a38
Fetching contributors…

Cannot retrieve contributors at this time

1138 lines (1011 sloc) 29.948 kB
/*
* 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 = 0; \
(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 ThreadSpecificData {
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-independant 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-independant 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 */
};
/*
*----------------------------------------------------------------------
*
* 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 =
Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
if (tsdPtr->doubleTypePtr == NULL) {
tsdPtr->doubleTypePtr = Tcl_GetObjType("double");
tsdPtr->intTypePtr = Tcl_GetObjType("int");
}
return tsdPtr;
}
/*
*----------------------------------------------------------------------
*
* 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;
}
/*
*----------------------------------------------------------------------
*
* 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);
}
/*
*----------------------------------------------------------------------
*
* 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;
}
/*
*----------------------------------------------------------------------
*
* 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;
}
/*
*----------------------------------------------------------------------
*
* 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(
register Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
register 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 = 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(
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_GetStringFromObj(objPtr, NULL);
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 = 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));
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* 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 = 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(
Tcl_Obj *objPtr) /* MM object with internal rep to free. */
{
ckfree(objPtr->internalRep.otherValuePtr);
objPtr->internalRep.otherValuePtr = NULL;
objPtr->typePtr = 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(
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 = srcPtr->internalRep.otherValuePtr;
newPtr = ckalloc(sizeof(MMRep));
newPtr->value = oldPtr->value;
newPtr->units = oldPtr->units;
newPtr->tkwin = oldPtr->tkwin;
newPtr->returnValue = oldPtr->returnValue;
copyPtr->internalRep.otherValuePtr = newPtr;
}
/*
*----------------------------------------------------------------------
*
* 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(
register Tcl_Obj *objPtr) /* pixel obj with string rep to update. */
{
MMRep *mmPtr;
char buffer[TCL_DOUBLE_SPACE];
register int len;
mmPtr = objPtr->internalRep.otherValuePtr;
/* 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 = (int)strlen(buffer);
objPtr->bytes = ckalloc(len + 1);
strcpy(objPtr->bytes, buffer);
objPtr->length = len;
}
/*
*----------------------------------------------------------------------
*
* 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_GetStringFromObj(objPtr, NULL);
} else {
/*
* It wasn't a known int or double, so parse it.
*/
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,
"\"", 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 = ckalloc(sizeof(MMRep));
mmPtr->value = d;
mmPtr->units = units;
mmPtr->tkwin = NULL;
mmPtr->returnValue = d;
objPtr->internalRep.otherValuePtr = 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(
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;
register WindowRep *winPtr;
int result;
result = Tcl_ConvertToType(interp, objPtr, &windowObjType);
if (result != TCL_OK) {
return result;
}
winPtr = objPtr->internalRep.otherValuePtr;
if (winPtr->tkwin == NULL
|| winPtr->mainPtr == NULL
|| winPtr->mainPtr != mainPtr
|| winPtr->epoch != mainPtr->deletionEpoch) {
/*
* Cache is invalid.
*/
winPtr->tkwin = Tk_NameToWindow(interp,
Tcl_GetStringFromObj(objPtr, NULL), 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;
}
/*
*----------------------------------------------------------------------
*
* 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_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr) /* The object to convert. */
{
const Tcl_ObjType *typePtr;
WindowRep *winPtr;
/*
* 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);
}
winPtr = ckalloc(sizeof(WindowRep));
winPtr->tkwin = NULL;
winPtr->mainPtr = NULL;
winPtr->epoch = 0;
objPtr->internalRep.otherValuePtr = winPtr;
objPtr->typePtr = &windowObjType;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* 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(
register Tcl_Obj *srcPtr,
register Tcl_Obj *copyPtr)
{
register WindowRep *oldPtr, *newPtr;
oldPtr = srcPtr->internalRep.otherValuePtr;
newPtr = ckalloc(sizeof(WindowRep));
newPtr->tkwin = oldPtr->tkwin;
newPtr->mainPtr = oldPtr->mainPtr;
newPtr->epoch = oldPtr->epoch;
copyPtr->internalRep.otherValuePtr = newPtr;
copyPtr->typePtr = srcPtr->typePtr;
}
/*
*----------------------------------------------------------------------
*
* 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.otherValuePtr);
objPtr->internalRep.otherValuePtr = NULL;
objPtr->typePtr = NULL;
}
/*
*----------------------------------------------------------------------
*
* 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;
register WindowRep *winPtr;
SetWindowFromAny(NULL, objPtr);
winPtr = objPtr->internalRep.otherValuePtr;
winPtr->tkwin = tkwin;
winPtr->mainPtr = mainPtr;
winPtr->epoch = mainPtr->deletionEpoch;
return objPtr;
}
/*
*----------------------------------------------------------------------
*
* 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_ResetResult(interp);
Tcl_AppendResult(interp, "bad pad value \"",
Tcl_GetString(specObj),
"\": must be positive screen distance", 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_AppendResult(interp,
"wrong number of parts to pad specification", NULL);
return TCL_ERROR;
}
/*
* Parse the first part.
*/
if (Tk_GetPixelsFromObj(interp, tkwin, objv[0], &firstInt) != TCL_OK ||
(firstInt < 0)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "bad pad value \"", Tcl_GetString(objv[0]),
"\": must be positive screen distance", 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_ResetResult(interp);
Tcl_AppendResult(interp, "bad 2nd pad value \"",
Tcl_GetString(objv[1]),
"\": must be positive screen distance", 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;
}
/*
*----------------------------------------------------------------------
*
* TkRegisterObjTypes --
*
* Registers Tk's Tcl_ObjType structures with the Tcl run-time.
*
* Results:
* None
*
* Side effects:
* All instances of Tcl_ObjType structues 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);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
Jump to Line
Something went wrong with that request. Please try again.