src/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	dashley	71	/* $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 */