shared_source/c_tk_base_7_5_w_mods/tkobj.c

/* $Header$ */

/* 
 * 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.1.1.1 2001/06/13 05:06:19 dtashley 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;
}

/* End of tkobj.c */
1	/* $Header$ */
2
3	/*
4	* tkObj.c --
5	*
6	* This file contains procedures that implement the common Tk object
7	* types
8	*
9	* Copyright (c) 1997 Sun Microsystems, Inc.
10	*
11	* See the file "license.terms" for information on usage and redistribution
12	* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13	*
14	* RCS: @(#) $Id: tkobj.c,v 1.1.1.1 2001/06/13 05:06:19 dtashley Exp $
15	*/
16
17	#include "tkInt.h"
18
19	/*
20	* The following structure is the internal representation for pixel objects.
21	*/
22
23	typedef struct PixelRep {
24	double value;
25	int units;
26	Tk_Window tkwin;
27	int returnValue;
28	} PixelRep;
29
30	#define SIMPLE_PIXELREP(objPtr) \
31	((objPtr)->internalRep.twoPtrValue.ptr2 == 0)
32
33	#define SET_SIMPLEPIXEL(objPtr, intval) \
34	(objPtr)->internalRep.twoPtrValue.ptr1 = (VOID *) (intval); \
35	(objPtr)->internalRep.twoPtrValue.ptr2 = 0
36
37	#define GET_SIMPLEPIXEL(objPtr) \
38	((int) (objPtr)->internalRep.twoPtrValue.ptr1)
39
40	#define SET_COMPLEXPIXEL(objPtr, repPtr) \
41	(objPtr)->internalRep.twoPtrValue.ptr1 = 0; \
42	(objPtr)->internalRep.twoPtrValue.ptr2 = (VOID *) repPtr
43
44	#define GET_COMPLEXPIXEL(objPtr) \
45	((PixelRep *) (objPtr)->internalRep.twoPtrValue.ptr2)
46
47
48	/*
49	* The following structure is the internal representation for mm objects.
50	*/
51
52	typedef struct MMRep {
53	double value;
54	int units;
55	Tk_Window tkwin;
56	double returnValue;
57	} MMRep;
58
59	/*
60	* Prototypes for procedures defined later in this file:
61	*/
62
63	static void DupMMInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
64	Tcl_Obj *copyPtr));
65	static void DupPixelInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
66	Tcl_Obj *copyPtr));
67	static void FreeMMInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
68	static void FreePixelInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
69	static int SetMMFromAny _ANSI_ARGS_((Tcl_Interp *interp,
70	Tcl_Obj *objPtr));
71	static int SetPixelFromAny _ANSI_ARGS_((Tcl_Interp *interp,
72	Tcl_Obj *objPtr));
73	static int SetWindowFromAny _ANSI_ARGS_((Tcl_Interp *interp,
74	Tcl_Obj *objPtr));
75
76	/*
77	* The following structure defines the implementation of the "pixel"
78	* Tcl object, used for measuring distances. The pixel object remembers
79	* its initial display-independant settings.
80	*/
81
82	static Tcl_ObjType pixelObjType = {
83	"pixel", /* name */
84	FreePixelInternalRep, /* freeIntRepProc */
85	DupPixelInternalRep, /* dupIntRepProc */
86	NULL, /* updateStringProc */
87	SetPixelFromAny /* setFromAnyProc */
88	};
89
90	/*
91	* The following structure defines the implementation of the "pixel"
92	* Tcl object, used for measuring distances. The pixel object remembers
93	* its initial display-independant settings.
94	*/
95
96	static Tcl_ObjType mmObjType = {
97	"mm", /* name */
98	FreeMMInternalRep, /* freeIntRepProc */
99	DupMMInternalRep, /* dupIntRepProc */
100	NULL, /* updateStringProc */
101	SetMMFromAny /* setFromAnyProc */
102	};
103
104	/*
105	* The following structure defines the implementation of the "window"
106	* Tcl object.
107	*/
108
109	static Tcl_ObjType windowObjType = {
110	"window", /* name */
111	(Tcl_FreeInternalRepProc ) NULL, / freeIntRepProc */
112	(Tcl_DupInternalRepProc ) NULL, / dupIntRepProc */
113	NULL, /* updateStringProc */
114	SetWindowFromAny /* setFromAnyProc */
115	};
116
117
118
119	/*
120	*----------------------------------------------------------------------
121	*
122	* Tk_GetPixelsFromObj --
123	*
124	* Attempt to return a pixel value from the Tcl object "objPtr". If the
125	* object is not already a pixel value, an attempt will be made to convert
126	* it to one.
127	*
128	* Results:
129	* The return value is a standard Tcl object result. If an error occurs
130	* during conversion, an error message is left in the interpreter's
131	* result unless "interp" is NULL.
132	*
133	* Side effects:
134	* If the object is not already a pixel, the conversion will free
135	* any old internal representation.
136	*
137	*----------------------------------------------------------------------
138	*/
139
140	int
141	Tk_GetPixelsFromObj(interp, tkwin, objPtr, intPtr)
142	Tcl_Interp interp; / Used for error reporting if not NULL. */
143	Tk_Window tkwin;
144	Tcl_Obj objPtr; / The object from which to get pixels. */
145	int intPtr; / Place to store resulting pixels. */
146	{
147	int result;
148	double d;
149	PixelRep *pixelPtr;
150	static double bias[] = {
151	1.0, 10.0, 25.4, 25.4 / 72.0
152	};
153
154	if (objPtr->typePtr != &pixelObjType) {
155	result = SetPixelFromAny(interp, objPtr);
156	if (result != TCL_OK) {
157	return result;
158	}
159	}
160
161	if (SIMPLE_PIXELREP(objPtr)) {
162	*intPtr = GET_SIMPLEPIXEL(objPtr);
163	} else {
164	pixelPtr = GET_COMPLEXPIXEL(objPtr);
165	if (pixelPtr->tkwin != tkwin) {
166	d = pixelPtr->value;
167	if (pixelPtr->units >= 0) {
168	d = bias[pixelPtr->units] WidthOfScreen(Tk_Screen(tkwin));
169	d /= WidthMMOfScreen(Tk_Screen(tkwin));
170	}
171	if (d < 0) {
172	pixelPtr->returnValue = (int) (d - 0.5);
173	} else {
174	pixelPtr->returnValue = (int) (d + 0.5);
175	}
176	pixelPtr->tkwin = tkwin;
177	}
178	*intPtr = pixelPtr->returnValue;
179	}
180	return TCL_OK;
181	}
182
183	/*
184	*----------------------------------------------------------------------
185	*
186	* FreePixelInternalRep --
187	*
188	* Deallocate the storage associated with a pixel object's internal
189	* representation.
190	*
191	* Results:
192	* None.
193	*
194	* Side effects:
195	* Frees objPtr's internal representation and sets objPtr's
196	* internalRep to NULL.
197	*
198	*----------------------------------------------------------------------
199	*/
200
201	static void
202	FreePixelInternalRep(objPtr)
203	Tcl_Obj objPtr; / Pixel object with internal rep to free. */
204	{
205	PixelRep *pixelPtr;
206
207	if (!SIMPLE_PIXELREP(objPtr)) {
208	pixelPtr = GET_COMPLEXPIXEL(objPtr);
209	ckfree((char *) pixelPtr);
210	}
211	SET_SIMPLEPIXEL(objPtr, 0);
212	}
213
214	/*
215	*----------------------------------------------------------------------
216	*
217	* DupPixelInternalRep --
218	*
219	* Initialize the internal representation of a pixel Tcl_Obj to a
220	* copy of the internal representation of an existing pixel object.
221	*
222	* Results:
223	* None.
224	*
225	* Side effects:
226	* copyPtr's internal rep is set to the pixel corresponding to
227	* srcPtr's internal rep.
228	*
229	*----------------------------------------------------------------------
230	*/
231
232	static void
233	DupPixelInternalRep(srcPtr, copyPtr)
234	register Tcl_Obj srcPtr; / Object with internal rep to copy. */
235	register Tcl_Obj copyPtr; / Object with internal rep to set. */
236	{
237	PixelRep oldPtr, newPtr;
238
239	copyPtr->typePtr = srcPtr->typePtr;
240
241	if (SIMPLE_PIXELREP(srcPtr)) {
242	SET_SIMPLEPIXEL(copyPtr, GET_SIMPLEPIXEL(srcPtr));
243	} else {
244	oldPtr = GET_COMPLEXPIXEL(srcPtr);
245	newPtr = (PixelRep *) ckalloc(sizeof(PixelRep));
246	newPtr->value = oldPtr->value;
247	newPtr->units = oldPtr->units;
248	newPtr->tkwin = oldPtr->tkwin;
249	newPtr->returnValue = oldPtr->returnValue;
250	SET_COMPLEXPIXEL(copyPtr, newPtr);
251	}
252	}
253
254	/*
255	*----------------------------------------------------------------------
256	*
257	* SetPixelFromAny --
258	*
259	* Attempt to generate a pixel internal form for the Tcl object
260	* "objPtr".
261	*
262	* Results:
263	* The return value is a standard Tcl result. If an error occurs during
264	* conversion, an error message is left in the interpreter's result
265	* unless "interp" is NULL.
266	*
267	* Side effects:
268	* If no error occurs, a pixel representation of the object is
269	* stored internally and the type of "objPtr" is set to pixel.
270	*
271	*----------------------------------------------------------------------
272	*/
273
274	static int
275	SetPixelFromAny(interp, objPtr)
276	Tcl_Interp interp; / Used for error reporting if not NULL. */
277	Tcl_Obj objPtr; / The object to convert. */
278	{
279	Tcl_ObjType *typePtr;
280	char string, rest;
281	double d;
282	int i, units;
283	PixelRep *pixelPtr;
284
285	string = Tcl_GetStringFromObj(objPtr, NULL);
286
287	d = strtod(string, &rest);
288	if (rest == string) {
289	/*
290	* Must copy string before resetting the result in case a caller
291	* is trying to convert the interpreter's result to pixels.
292	*/
293
294	char buf[100];
295
296	error:
297	sprintf(buf, "bad screen distance \"%.50s\"", string);
298	Tcl_ResetResult(interp);
299	Tcl_AppendResult(interp, buf, NULL);
300	return TCL_ERROR;
301	}
302	while ((rest != '\0') && isspace(UCHAR(rest))) {
303	rest++;
304	}
305	switch (*rest) {
306	case '\0':
307	units = -1;
308	break;
309
310	case 'm':
311	units = 0;
312	break;
313
314	case 'c':
315	units = 1;
316	break;
317
318	case 'i':
319	units = 2;
320	break;
321
322	case 'p':
323	units = 3;
324	break;
325
326	default:
327	goto error;
328	}
329
330	/*
331	* Free the old internalRep before setting the new one.
332	*/
333
334	typePtr = objPtr->typePtr;
335	if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
336	(*typePtr->freeIntRepProc)(objPtr);
337	}
338
339	objPtr->typePtr = &pixelObjType;
340
341	i = (int) d;
342	if ((units < 0) && (i == d)) {
343	SET_SIMPLEPIXEL(objPtr, i);
344	} else {
345	pixelPtr = (PixelRep *) ckalloc(sizeof(PixelRep));
346	pixelPtr->value = d;
347	pixelPtr->units = units;
348	pixelPtr->tkwin = NULL;
349	pixelPtr->returnValue = i;
350	SET_COMPLEXPIXEL(objPtr, pixelPtr);
351	}
352	return TCL_OK;
353	}
354
355	/*
356	*----------------------------------------------------------------------
357	*
358	* Tk_GetMMFromObj --
359	*
360	* Attempt to return an mm value from the Tcl object "objPtr". If the
361	* object is not already an mm value, an attempt will be made to convert
362	* it to one.
363	*
364	* Results:
365	* The return value is a standard Tcl object result. If an error occurs
366	* during conversion, an error message is left in the interpreter's
367	* result unless "interp" is NULL.
368	*
369	* Side effects:
370	* If the object is not already a pixel, the conversion will free
371	* any old internal representation.
372	*
373	*----------------------------------------------------------------------
374	*/
375
376	int
377	Tk_GetMMFromObj(interp, tkwin, objPtr, doublePtr)
378	Tcl_Interp interp; / Used for error reporting if not NULL. */
379	Tk_Window tkwin;
380	Tcl_Obj objPtr; / The object from which to get mms. */
381	double doublePtr; / Place to store resulting millimeters. */
382	{
383	int result;
384	double d;
385	MMRep *mmPtr;
386	static double bias[] = {
387	10.0, 25.4, 1.0, 25.4 / 72.0
388	};
389
390	if (objPtr->typePtr != &mmObjType) {
391	result = SetMMFromAny(interp, objPtr);
392	if (result != TCL_OK) {
393	return result;
394	}
395	}
396
397	mmPtr = (MMRep *) objPtr->internalRep.otherValuePtr;
398	if (mmPtr->tkwin != tkwin) {
399	d = mmPtr->value;
400	if (mmPtr->units == -1) {
401	d /= WidthOfScreen(Tk_Screen(tkwin));
402	d *= WidthMMOfScreen(Tk_Screen(tkwin));
403	} else {
404	d *= bias[mmPtr->units];
405	}
406	mmPtr->tkwin = tkwin;
407	mmPtr->returnValue = d;
408	}
409	*doublePtr = mmPtr->returnValue;
410
411	return TCL_OK;
412	}
413
414	/*
415	*----------------------------------------------------------------------
416	*
417	* FreeMMInternalRep --
418	*
419	* Deallocate the storage associated with a mm object's internal
420	* representation.
421	*
422	* Results:
423	* None.
424	*
425	* Side effects:
426	* Frees objPtr's internal representation and sets objPtr's
427	* internalRep to NULL.
428	*
429	*----------------------------------------------------------------------
430	*/
431
432	static void
433	FreeMMInternalRep(objPtr)
434	Tcl_Obj objPtr; / MM object with internal rep to free. */
435	{
436	ckfree((char *) objPtr->internalRep.otherValuePtr);
437	objPtr->internalRep.otherValuePtr = NULL;
438	}
439
440	/*
441	*----------------------------------------------------------------------
442	*
443	* DupMMInternalRep --
444	*
445	* Initialize the internal representation of a pixel Tcl_Obj to a
446	* copy of the internal representation of an existing pixel object.
447	*
448	* Results:
449	* None.
450	*
451	* Side effects:
452	* copyPtr's internal rep is set to the pixel corresponding to
453	* srcPtr's internal rep.
454	*
455	*----------------------------------------------------------------------
456	*/
457
458	static void
459	DupMMInternalRep(srcPtr, copyPtr)
460	register Tcl_Obj srcPtr; / Object with internal rep to copy. */
461	register Tcl_Obj copyPtr; / Object with internal rep to set. */
462	{
463	MMRep oldPtr, newPtr;
464
465	copyPtr->typePtr = srcPtr->typePtr;
466	oldPtr = (MMRep *) srcPtr->internalRep.otherValuePtr;
467	newPtr = (MMRep *) ckalloc(sizeof(MMRep));
468	newPtr->value = oldPtr->value;
469	newPtr->units = oldPtr->units;
470	newPtr->tkwin = oldPtr->tkwin;
471	newPtr->returnValue = oldPtr->returnValue;
472	copyPtr->internalRep.otherValuePtr = (VOID *) newPtr;
473	}
474
475	/*
476	*----------------------------------------------------------------------
477	*
478	* SetMMFromAny --
479	*
480	* Attempt to generate a mm internal form for the Tcl object
481	* "objPtr".
482	*
483	* Results:
484	* The return value is a standard Tcl result. If an error occurs during
485	* conversion, an error message is left in the interpreter's result
486	* unless "interp" is NULL.
487	*
488	* Side effects:
489	* If no error occurs, a mm representation of the object is
490	* stored internally and the type of "objPtr" is set to mm.
491	*
492	*----------------------------------------------------------------------
493	*/
494
495	static int
496	SetMMFromAny(interp, objPtr)
497	Tcl_Interp interp; / Used for error reporting if not NULL. */
498	Tcl_Obj objPtr; / The object to convert. */
499	{
500	Tcl_ObjType *typePtr;
501	char string, rest;
502	double d;
503	int units;
504	MMRep *mmPtr;
505
506	string = Tcl_GetStringFromObj(objPtr, NULL);
507
508	d = strtod(string, &rest);
509	if (rest == string) {
510	/*
511	* Must copy string before resetting the result in case a caller
512	* is trying to convert the interpreter's result to mms.
513	*/
514
515	error:
516	Tcl_AppendResult(interp, "bad screen distance \"", string,
517	"\"", (char *) NULL);
518	return TCL_ERROR;
519	}
520	while ((rest != '\0') && isspace(UCHAR(rest))) {
521	rest++;
522	}
523	switch (*rest) {
524	case '\0':
525	units = -1;
526	break;
527
528	case 'c':
529	units = 0;
530	break;
531
532	case 'i':
533	units = 1;
534	break;
535
536	case 'm':
537	units = 2;
538	break;
539
540	case 'p':
541	units = 3;
542	break;
543
544	default:
545	goto error;
546	}
547
548	/*
549	* Free the old internalRep before setting the new one.
550	*/
551
552	typePtr = objPtr->typePtr;
553	if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
554	(*typePtr->freeIntRepProc)(objPtr);
555	}
556
557	objPtr->typePtr = &mmObjType;
558
559	mmPtr = (MMRep *) ckalloc(sizeof(MMRep));
560	mmPtr->value = d;
561	mmPtr->units = units;
562	mmPtr->tkwin = NULL;
563	mmPtr->returnValue = d;
564	objPtr->internalRep.otherValuePtr = (VOID *) mmPtr;
565	return TCL_OK;
566	}
567
568	/*
569	*----------------------------------------------------------------------
570	*
571	* TkGetWindowFromObj --
572	*
573	* Attempt to return a Tk_Window from the Tcl object "objPtr". If the
574	* object is not already a Tk_Window, an attempt will be made to convert
575	* it to one.
576	*
577	* Results:
578	* The return value is a standard Tcl object result. If an error occurs
579	* during conversion, an error message is left in the interpreter's
580	* result unless "interp" is NULL.
581	*
582	* Side effects:
583	* If the object is not already a Tk_Window, the conversion will free
584	* any old internal representation.
585	*
586	*----------------------------------------------------------------------
587	*/
588
589	int
590	TkGetWindowFromObj(interp, tkwin, objPtr, windowPtr)
591	Tcl_Interp interp; / Used for error reporting if not NULL. */
592	Tk_Window tkwin; /* A token to get the main window from. */
593	register Tcl_Obj objPtr; / The object from which to get boolean. */
594	Tk_Window windowPtr; / Place to store resulting window. */
595	{
596	register int result;
597	Tk_Window lastWindow;
598
599	result = SetWindowFromAny(interp, objPtr);
600	if (result != TCL_OK) {
601	return result;
602	}
603
604	lastWindow = (Tk_Window) objPtr->internalRep.twoPtrValue.ptr1;
605	if (tkwin != lastWindow) {
606	Tk_Window foundWindow = Tk_NameToWindow(interp,
607	Tcl_GetStringFromObj(objPtr, NULL), tkwin);
608
609	if (foundWindow == NULL) {
610	return TCL_ERROR;
611	}
612	objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tkwin;
613	objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) foundWindow;
614	}
615	*windowPtr = (Tk_Window) objPtr->internalRep.twoPtrValue.ptr2;
616
617	return result;
618	}
619
620	/*
621	*----------------------------------------------------------------------
622	*
623	* SetWindowFromAny --
624	*
625	* Attempt to generate a Tk_Window internal form for the Tcl object
626	* "objPtr".
627	*
628	* Results:
629	* The return value is a standard Tcl result. If an error occurs during
630	* conversion, an error message is left in the interpreter's result
631	* unless "interp" is NULL.
632	*
633	* Side effects:
634	* If no error occurs, a standard window value is stored as "objPtr"s
635	* internal representation and the type of "objPtr" is set to Tk_Window.
636	*
637	*----------------------------------------------------------------------
638	*/
639
640	static int
641	SetWindowFromAny(interp, objPtr)
642	Tcl_Interp interp; / Used for error reporting if not NULL. */
643	register Tcl_Obj objPtr; / The object to convert. */
644	{
645	Tcl_ObjType *typePtr;
646
647	/*
648	* Free the old internalRep before setting the new one.
649	*/
650
651	Tcl_GetStringFromObj(objPtr, NULL);
652	typePtr = objPtr->typePtr;
653	if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
654	(*typePtr->freeIntRepProc)(objPtr);
655	}
656	objPtr->typePtr = &windowObjType;
657	objPtr->internalRep.twoPtrValue.ptr1 = NULL;
658	objPtr->internalRep.twoPtrValue.ptr2 = NULL;
659
660	return TCL_OK;
661	}
662
663	/* End of tkobj.c */