* Merged 8.1 branch into the main trunk

1 files changed, 659 insertions, 0 deletions

diff --git a/generic/tkObj.c b/generic/tkObj.c
new file mode 100644
index 0000000..ff2684c
--- /dev/null
+++ b/generic/tkObj.c
@@ -0,0 +1,659 @@
+/* 
+ * tkObj.c --
+ *
+ *	This file contains procedures that implement the common Tk object
+ *	types
+ *
+ * Copyright (c) 1997 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkObj.c,v 1.2 1999/04/16 01:51:20 stanton Exp $
+ */
+
+#include "tkInt.h"
+
+/*
+ * The following structure is the internal representation for pixel objects.
+ */
+ 
+typedef struct PixelRep {
+    double value;
+    int units;
+    Tk_Window tkwin;
+    int returnValue;
+} PixelRep;
+
+#define SIMPLE_PIXELREP(objPtr)				\
+    ((objPtr)->internalRep.twoPtrValue.ptr2 == 0)
+
+#define SET_SIMPLEPIXEL(objPtr, intval)			\
+    (objPtr)->internalRep.twoPtrValue.ptr1 = (VOID *) (intval);	\
+    (objPtr)->internalRep.twoPtrValue.ptr2 = 0
+
+#define GET_SIMPLEPIXEL(objPtr)				\
+    ((int) (objPtr)->internalRep.twoPtrValue.ptr1)
+
+#define SET_COMPLEXPIXEL(objPtr, repPtr)		\
+    (objPtr)->internalRep.twoPtrValue.ptr1 = 0;		\
+    (objPtr)->internalRep.twoPtrValue.ptr2 = (VOID *) repPtr
+
+#define GET_COMPLEXPIXEL(objPtr)			\
+    ((PixelRep *) (objPtr)->internalRep.twoPtrValue.ptr2)
+
+
+/*
+ * The following structure is the internal representation for mm objects.
+ */
+ 
+typedef struct MMRep {
+    double value;
+    int units;
+    Tk_Window tkwin;
+    double returnValue;
+} MMRep;
+
+/*
+ * Prototypes for procedures defined later in this file:
+ */
+
+static void		DupMMInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
+			    Tcl_Obj *copyPtr));
+static void		DupPixelInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
+			    Tcl_Obj *copyPtr));
+static void		FreeMMInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
+static void		FreePixelInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
+static int		SetMMFromAny _ANSI_ARGS_((Tcl_Interp *interp,
+			    Tcl_Obj *objPtr));
+static int		SetPixelFromAny _ANSI_ARGS_((Tcl_Interp *interp,
+			    Tcl_Obj *objPtr));
+static int		SetWindowFromAny _ANSI_ARGS_((Tcl_Interp *interp,
+			    Tcl_Obj *objPtr));
+			
+/*
+ * The following structure defines the implementation of the "pixel"
+ * Tcl object, used for measuring distances.  The pixel object remembers
+ * its initial display-independant settings.
+ */
+
+static Tcl_ObjType pixelObjType = {
+    "pixel",			/* name */
+    FreePixelInternalRep,	/* freeIntRepProc */
+    DupPixelInternalRep,	/* dupIntRepProc */
+    NULL,			/* updateStringProc */
+    SetPixelFromAny		/* setFromAnyProc */
+};
+
+/*
+ * The following structure defines the implementation of the "pixel"
+ * Tcl object, used for measuring distances.  The pixel object remembers
+ * its initial display-independant settings.
+ */
+
+static Tcl_ObjType mmObjType = {
+    "mm",			/* name */
+    FreeMMInternalRep,		/* freeIntRepProc */
+    DupMMInternalRep,		/* dupIntRepProc */
+    NULL,			/* updateStringProc */
+    SetMMFromAny		/* setFromAnyProc */
+};
+
+/*
+ * The following structure defines the implementation of the "window"
+ * Tcl object.
+ */
+
+static Tcl_ObjType windowObjType = {
+    "window",				/* name */
+    (Tcl_FreeInternalRepProc *) NULL,   /* freeIntRepProc */
+    (Tcl_DupInternalRepProc *) NULL,	/* dupIntRepProc */
+    NULL,				/* updateStringProc */
+    SetWindowFromAny			/* setFromAnyProc */
+};
+
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_GetPixelsFromObj --
+ *
+ *	Attempt to return a pixel value from the Tcl object "objPtr". If the
+ *	object is not already a pixel value, an attempt will be made to convert
+ *	it to one.
+ *
+ * Results:
+ *	The return value is a standard Tcl object result. If an error occurs
+ *	during conversion, an error message is left in the interpreter's
+ *	result unless "interp" is NULL.
+ *
+ * Side effects:
+ *	If the object is not already a pixel, the conversion will free
+ *	any old internal representation. 
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tk_GetPixelsFromObj(interp, tkwin, objPtr, intPtr)
+    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
+    Tk_Window tkwin;
+    Tcl_Obj *objPtr;		/* The object from which to get pixels. */
+    int *intPtr;		/* Place to store resulting pixels. */
+{
+    int result;
+    double d;
+    PixelRep *pixelPtr;
+    static double bias[] = {
+	1.0,	10.0,	25.4,	25.4 / 72.0
+    };
+
+    if (objPtr->typePtr != &pixelObjType) {
+	result = SetPixelFromAny(interp, objPtr);
+	if (result != TCL_OK) {
+	    return result;
+	}
+    }
+
+    if (SIMPLE_PIXELREP(objPtr)) {
+	*intPtr = GET_SIMPLEPIXEL(objPtr);
+    } else {
+	pixelPtr = GET_COMPLEXPIXEL(objPtr);
+	if (pixelPtr->tkwin != tkwin) {
+	    d = pixelPtr->value;
+	    if (pixelPtr->units >= 0) {
+		d *= bias[pixelPtr->units] * WidthOfScreen(Tk_Screen(tkwin));
+		d /= WidthMMOfScreen(Tk_Screen(tkwin));
+	    }
+	    if (d < 0) {
+		pixelPtr->returnValue = (int) (d - 0.5);
+	    } else {
+		pixelPtr->returnValue = (int) (d + 0.5);
+	    }
+	    pixelPtr->tkwin = tkwin;
+	}
+        *intPtr = pixelPtr->returnValue;
+    }
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreePixelInternalRep --
+ *
+ *	Deallocate the storage associated with a pixel object's internal
+ *	representation.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Frees objPtr's internal representation and sets objPtr's
+ *	internalRep to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreePixelInternalRep(objPtr)
+    Tcl_Obj *objPtr;		/* Pixel object with internal rep to free. */
+{
+    PixelRep *pixelPtr;
+    
+    if (!SIMPLE_PIXELREP(objPtr)) {
+	pixelPtr = GET_COMPLEXPIXEL(objPtr);
+	ckfree((char *) pixelPtr);
+    }
+    SET_SIMPLEPIXEL(objPtr, 0);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupPixelInternalRep --
+ *
+ *	Initialize the internal representation of a pixel Tcl_Obj to a
+ *	copy of the internal representation of an existing pixel object. 
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	copyPtr's internal rep is set to the pixel corresponding to
+ *	srcPtr's internal rep.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupPixelInternalRep(srcPtr, copyPtr)
+    register Tcl_Obj *srcPtr;	/* Object with internal rep to copy. */
+    register Tcl_Obj *copyPtr;	/* Object with internal rep to set. */
+{
+    PixelRep *oldPtr, *newPtr;
+    
+    copyPtr->typePtr = srcPtr->typePtr;
+
+    if (SIMPLE_PIXELREP(srcPtr)) {
+	SET_SIMPLEPIXEL(copyPtr, GET_SIMPLEPIXEL(srcPtr));
+    } else {
+	oldPtr = GET_COMPLEXPIXEL(srcPtr);
+	newPtr = (PixelRep *) ckalloc(sizeof(PixelRep));
+	newPtr->value = oldPtr->value;
+	newPtr->units = oldPtr->units;
+	newPtr->tkwin = oldPtr->tkwin;
+	newPtr->returnValue = oldPtr->returnValue;
+	SET_COMPLEXPIXEL(copyPtr, newPtr);
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetPixelFromAny --
+ *
+ *	Attempt to generate a pixel internal form for the Tcl object
+ *	"objPtr".
+ *
+ * Results:
+ *	The return value is a standard Tcl result. If an error occurs during
+ *	conversion, an error message is left in the interpreter's result
+ *	unless "interp" is NULL.
+ *
+ * Side effects:
+ *	If no error occurs, a pixel representation of the object is
+ *	stored internally and the type of "objPtr" is set to pixel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetPixelFromAny(interp, objPtr)
+    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
+    Tcl_Obj *objPtr;		/* The object to convert. */
+{
+    Tcl_ObjType *typePtr;
+    char *string, *rest;
+    double d;
+    int i, units;
+    PixelRep *pixelPtr;
+
+    string = Tcl_GetStringFromObj(objPtr, NULL);
+
+    d = strtod(string, &rest);
+    if (rest == string) {
+	/*
+	 * Must copy string before resetting the result in case a caller
+	 * is trying to convert the interpreter's result to pixels.
+	 */
+
+	char buf[100];
+
+	error:
+	sprintf(buf, "bad screen distance \"%.50s\"", string);
+	Tcl_ResetResult(interp);
+	Tcl_AppendResult(interp, buf, NULL);
+	return TCL_ERROR;
+    }
+    while ((*rest != '\0') && isspace(UCHAR(*rest))) {
+	rest++;
+    }
+    switch (*rest) {
+	case '\0':
+	    units = -1;
+	    break;
+
+	case 'm':
+	    units = 0;
+	    break;
+
+	case 'c':
+	    units = 1;
+	    break;
+
+	case 'i':
+	    units = 2;
+	    break;
+
+	case 'p':
+	    units = 3;
+	    break;
+
+	default:
+	    goto error;
+    }
+
+    /*
+     * Free the old internalRep before setting the new one. 
+     */
+
+    typePtr = objPtr->typePtr;
+    if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
+	(*typePtr->freeIntRepProc)(objPtr);
+    }
+
+    objPtr->typePtr = &pixelObjType;
+
+    i = (int) d;
+    if ((units < 0) && (i == d)) {
+	SET_SIMPLEPIXEL(objPtr, i);
+    } else {
+	pixelPtr = (PixelRep *) ckalloc(sizeof(PixelRep));
+	pixelPtr->value = d;
+	pixelPtr->units = units;
+	pixelPtr->tkwin = NULL;
+	pixelPtr->returnValue = i;
+	SET_COMPLEXPIXEL(objPtr, pixelPtr);
+    }
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_GetMMFromObj --
+ *
+ *	Attempt to return an mm value from the Tcl object "objPtr". If the
+ *	object is not already an mm value, an attempt will be made to convert
+ *	it to one.
+ *
+ * Results:
+ *	The return value is a standard Tcl object result. If an error occurs
+ *	during conversion, an error message is left in the interpreter's
+ *	result unless "interp" is NULL.
+ *
+ * Side effects:
+ *	If the object is not already a pixel, the conversion will free
+ *	any old internal representation. 
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tk_GetMMFromObj(interp, tkwin, objPtr, doublePtr)
+    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
+    Tk_Window tkwin;
+    Tcl_Obj *objPtr;		/* The object from which to get mms. */
+    double *doublePtr;		/* Place to store resulting millimeters. */
+{
+    int result;
+    double d;
+    MMRep *mmPtr;
+    static double bias[] = {
+	10.0,	25.4,	1.0,	25.4 / 72.0
+    };
+
+    if (objPtr->typePtr != &mmObjType) {
+	result = SetMMFromAny(interp, objPtr);
+	if (result != TCL_OK) {
+	    return result;
+	}
+    }
+
+    mmPtr = (MMRep *) objPtr->internalRep.otherValuePtr;
+    if (mmPtr->tkwin != tkwin) {
+	d = mmPtr->value;
+	if (mmPtr->units == -1) {
+	    d /= WidthOfScreen(Tk_Screen(tkwin));
+	    d *= WidthMMOfScreen(Tk_Screen(tkwin));
+	} else {
+	    d *= bias[mmPtr->units];
+	}
+	mmPtr->tkwin = tkwin;
+	mmPtr->returnValue = d;
+    }
+    *doublePtr = mmPtr->returnValue;
+
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeMMInternalRep --
+ *
+ *	Deallocate the storage associated with a mm object's internal
+ *	representation.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Frees objPtr's internal representation and sets objPtr's
+ *	internalRep to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeMMInternalRep(objPtr)
+    Tcl_Obj *objPtr;		/* MM object with internal rep to free. */
+{
+    ckfree((char *) objPtr->internalRep.otherValuePtr);
+    objPtr->internalRep.otherValuePtr = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupMMInternalRep --
+ *
+ *	Initialize the internal representation of a pixel Tcl_Obj to a
+ *	copy of the internal representation of an existing pixel object. 
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	copyPtr's internal rep is set to the pixel corresponding to
+ *	srcPtr's internal rep.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupMMInternalRep(srcPtr, copyPtr)
+    register Tcl_Obj *srcPtr;	/* Object with internal rep to copy. */
+    register Tcl_Obj *copyPtr;	/* Object with internal rep to set. */
+{
+    MMRep *oldPtr, *newPtr;
+    
+    copyPtr->typePtr = srcPtr->typePtr;
+    oldPtr = (MMRep *) srcPtr->internalRep.otherValuePtr;
+    newPtr = (MMRep *) ckalloc(sizeof(MMRep));
+    newPtr->value = oldPtr->value;
+    newPtr->units = oldPtr->units;
+    newPtr->tkwin = oldPtr->tkwin;
+    newPtr->returnValue = oldPtr->returnValue;
+    copyPtr->internalRep.otherValuePtr = (VOID *) newPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetMMFromAny --
+ *
+ *	Attempt to generate a mm internal form for the Tcl object
+ *	"objPtr".
+ *
+ * Results:
+ *	The return value is a standard Tcl result. If an error occurs during
+ *	conversion, an error message is left in the interpreter's result
+ *	unless "interp" is NULL.
+ *
+ * Side effects:
+ *	If no error occurs, a mm representation of the object is
+ *	stored internally and the type of "objPtr" is set to mm.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetMMFromAny(interp, objPtr)
+    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
+    Tcl_Obj *objPtr;		/* The object to convert. */
+{
+    Tcl_ObjType *typePtr;
+    char *string, *rest;
+    double d;
+    int units;
+    MMRep *mmPtr;
+
+    string = Tcl_GetStringFromObj(objPtr, NULL);
+
+    d = strtod(string, &rest);
+    if (rest == string) {
+	/*
+	 * Must copy string before resetting the result in case a caller
+	 * is trying to convert the interpreter's result to mms.
+	 */
+
+	error:
+	Tcl_AppendResult(interp, "bad screen distance \"", string,
+		"\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+    while ((*rest != '\0') && isspace(UCHAR(*rest))) {
+	rest++;
+    }
+    switch (*rest) {
+	case '\0':
+	    units = -1;
+	    break;
+
+	case 'c':
+	    units = 0;
+	    break;
+
+	case 'i':
+	    units = 1;
+	    break;
+
+	case 'm':
+	    units = 2;
+	    break;
+
+	case 'p':
+	    units = 3;
+	    break;
+
+	default:
+	    goto error;
+    }
+
+    /*
+     * Free the old internalRep before setting the new one. 
+     */
+
+    typePtr = objPtr->typePtr;
+    if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
+	(*typePtr->freeIntRepProc)(objPtr);
+    }
+
+    objPtr->typePtr = &mmObjType;
+
+    mmPtr = (MMRep *) ckalloc(sizeof(MMRep));
+    mmPtr->value = d;
+    mmPtr->units = units;
+    mmPtr->tkwin = NULL;
+    mmPtr->returnValue = d;
+    objPtr->internalRep.otherValuePtr = (VOID *) mmPtr;
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkGetWindowFromObj --
+ *
+ *	Attempt to return a Tk_Window from the Tcl object "objPtr". If the
+ *	object is not already a Tk_Window, an attempt will be made to convert
+ *	it to one.
+ *
+ * Results:
+ *	The return value is a standard Tcl object result. If an error occurs
+ *	during conversion, an error message is left in the interpreter's
+ *	result unless "interp" is NULL.
+ *
+ * Side effects:
+ *	If the object is not already a Tk_Window, the conversion will free
+ *	any old internal representation. 
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TkGetWindowFromObj(interp, tkwin, objPtr, windowPtr)
+    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
+    Tk_Window tkwin;		/* A token to get the main window from. */
+    register Tcl_Obj *objPtr;	/* The object from which to get boolean. */
+    Tk_Window *windowPtr;	/* Place to store resulting window. */
+{
+    register int result;
+    Tk_Window lastWindow;
+
+    result = SetWindowFromAny(interp, objPtr);
+    if (result != TCL_OK) {
+	return result;
+    }
+
+    lastWindow = (Tk_Window) objPtr->internalRep.twoPtrValue.ptr1;
+    if (tkwin != lastWindow) {
+	Tk_Window foundWindow = Tk_NameToWindow(interp,
+		Tcl_GetStringFromObj(objPtr, NULL), tkwin);
+
+	if (foundWindow == NULL) {
+	    return TCL_ERROR;
+	}
+	objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tkwin;
+	objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) foundWindow;
+    }
+    *windowPtr = (Tk_Window) objPtr->internalRep.twoPtrValue.ptr2;
+
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetWindowFromAny --
+ *
+ *	Attempt to generate a Tk_Window internal form for the Tcl object
+ *	"objPtr".
+ *
+ * Results:
+ *	The return value is a standard Tcl result. If an error occurs during
+ *	conversion, an error message is left in the interpreter's result
+ *	unless "interp" is NULL.
+ *
+ * Side effects:
+ *	If no error occurs, a standard window value is stored as "objPtr"s
+ *	internal representation and the type of "objPtr" is set to Tk_Window.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetWindowFromAny(interp, objPtr)
+    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
+    register Tcl_Obj *objPtr;	/* The object to convert. */
+{
+    Tcl_ObjType *typePtr;
+
+    /*
+     * Free the old internalRep before setting the new one. 
+     */
+
+    Tcl_GetStringFromObj(objPtr, NULL);
+    typePtr = objPtr->typePtr;
+    if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
+	(*typePtr->freeIntRepProc)(objPtr);
+    }
+    objPtr->typePtr = &windowObjType;
+    objPtr->internalRep.twoPtrValue.ptr1 = NULL;
+    objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+
+    return TCL_OK;
+}