Merge commit '6b095f3c8521ca7215e6ff5dcbada52b197ef7d0' as 'tk8.6'

1 files changed, 752 insertions, 0 deletions

diff --git a/tk8.6/generic/tkGet.c b/tk8.6/generic/tkGet.c
new file mode 100644
index 0000000..d58b4a5
--- /dev/null
+++ b/tk8.6/generic/tkGet.c
@@ -0,0 +1,752 @@
+/*
+ * tkGet.c --
+ *
+ *	This file contains a number of "Tk_GetXXX" procedures, which parse
+ *	text strings into useful forms for Tk. This file has the simpler
+ *	functions, like Tk_GetDirection and Tk_GetUid. The more complex
+ *	functions like Tk_GetColor are in separate files.
+ *
+ * Copyright (c) 1991-1994 The Regents of the University of California.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tkInt.h"
+
+/*
+ * One of these structures is created per thread to store thread-specific
+ * data. In this case, it is used to house the Tk_Uid structs used by each
+ * thread. The "dataKey" below is used to locate the ThreadSpecificData for
+ * the current thread.
+ */
+
+typedef struct ThreadSpecificData {
+    int initialized;
+    Tcl_HashTable uidTable;
+} ThreadSpecificData;
+static Tcl_ThreadDataKey dataKey;
+
+static void		FreeUidThreadExitProc(ClientData clientData);
+
+/*
+ * The following tables defines the string values for reliefs, which are
+ * used by Tk_GetAnchorFromObj and Tk_GetJustifyFromObj.
+ */
+
+static const char *const anchorStrings[] = {
+    "n", "ne", "e", "se", "s", "sw", "w", "nw", "center", NULL
+};
+static const char *const justifyStrings[] = {
+    "left", "right", "center", NULL
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_GetAnchorFromObj --
+ *
+ *	Return a Tk_Anchor value based on the value of the 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:
+ *	The object gets converted by Tcl_GetIndexFromObj.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tk_GetAnchorFromObj(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    Tcl_Obj *objPtr,		/* The object we are trying to get the value
+				 * from. */
+    Tk_Anchor *anchorPtr)	/* Where to place the Tk_Anchor that
+				 * corresponds to the string value of
+				 * objPtr. */
+{
+    int index, code;
+
+    code = Tcl_GetIndexFromObj(interp, objPtr, anchorStrings, "anchor", 0,
+	    &index);
+    if (code == TCL_OK) {
+	*anchorPtr = (Tk_Anchor) index;
+    }
+    return code;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_GetAnchor --
+ *
+ *	Given a string, return the corresponding Tk_Anchor.
+ *
+ * Results:
+ *	The return value is a standard Tcl return result. If TCL_OK is
+ *	returned, then everything went well and the position is stored at
+ *	*anchorPtr; otherwise TCL_ERROR is returned and an error message is
+ *	left in the interp's result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tk_GetAnchor(
+    Tcl_Interp *interp,		/* Use this for error reporting. */
+    const char *string,		/* String describing a direction. */
+    Tk_Anchor *anchorPtr)	/* Where to store Tk_Anchor corresponding to
+				 * string. */
+{
+    switch (string[0]) {
+    case 'n':
+	if (string[1] == 0) {
+	    *anchorPtr = TK_ANCHOR_N;
+	    return TCL_OK;
+	} else if ((string[1] == 'e') && (string[2] == 0)) {
+	    *anchorPtr = TK_ANCHOR_NE;
+	    return TCL_OK;
+	} else if ((string[1] == 'w') && (string[2] == 0)) {
+	    *anchorPtr = TK_ANCHOR_NW;
+	    return TCL_OK;
+	}
+	goto error;
+    case 's':
+	if (string[1] == 0) {
+	    *anchorPtr = TK_ANCHOR_S;
+	    return TCL_OK;
+	} else if ((string[1] == 'e') && (string[2] == 0)) {
+	    *anchorPtr = TK_ANCHOR_SE;
+	    return TCL_OK;
+	} else if ((string[1] == 'w') && (string[2] == 0)) {
+	    *anchorPtr = TK_ANCHOR_SW;
+	    return TCL_OK;
+	} else {
+	    goto error;
+	}
+    case 'e':
+	if (string[1] == 0) {
+	    *anchorPtr = TK_ANCHOR_E;
+	    return TCL_OK;
+	}
+	goto error;
+    case 'w':
+	if (string[1] == 0) {
+	    *anchorPtr = TK_ANCHOR_W;
+	    return TCL_OK;
+	}
+	goto error;
+    case 'c':
+	if (strncmp(string, "center", strlen(string)) == 0) {
+	    *anchorPtr = TK_ANCHOR_CENTER;
+	    return TCL_OK;
+	}
+	goto error;
+    }
+
+  error:
+    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+	    "bad anchor position \"%s\": must be"
+	    " n, ne, e, se, s, sw, w, nw, or center", string));
+    Tcl_SetErrorCode(interp, "TK", "VALUE", "ANCHOR", NULL);
+    return TCL_ERROR;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_NameOfAnchor --
+ *
+ *	Given a Tk_Anchor, return the string that corresponds to it.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	None.
+ *
+ *--------------------------------------------------------------
+ */
+
+const char *
+Tk_NameOfAnchor(
+    Tk_Anchor anchor)		/* Anchor for which identifying string is
+				 * desired. */
+{
+    switch (anchor) {
+    case TK_ANCHOR_N: return "n";
+    case TK_ANCHOR_NE: return "ne";
+    case TK_ANCHOR_E: return "e";
+    case TK_ANCHOR_SE: return "se";
+    case TK_ANCHOR_S: return "s";
+    case TK_ANCHOR_SW: return "sw";
+    case TK_ANCHOR_W: return "w";
+    case TK_ANCHOR_NW: return "nw";
+    case TK_ANCHOR_CENTER: return "center";
+    }
+    return "unknown anchor position";
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_GetJoinStyle --
+ *
+ *	Given a string, return the corresponding Tk JoinStyle.
+ *
+ * Results:
+ *	The return value is a standard Tcl return result. If TCL_OK is
+ *	returned, then everything went well and the justification is stored at
+ *	*joinPtr; otherwise TCL_ERROR is returned and an error message is left
+ *	in the interp's result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tk_GetJoinStyle(
+    Tcl_Interp *interp,		/* Use this for error reporting. */
+    const char *string,		/* String describing a justification style. */
+    int *joinPtr)		/* Where to store join style corresponding to
+				 * string. */
+{
+    int c;
+    size_t length;
+
+    c = string[0];
+    length = strlen(string);
+
+    if ((c == 'b') && (strncmp(string, "bevel", length) == 0)) {
+	*joinPtr = JoinBevel;
+	return TCL_OK;
+    }
+    if ((c == 'm') && (strncmp(string, "miter", length) == 0)) {
+	*joinPtr = JoinMiter;
+	return TCL_OK;
+    }
+    if ((c == 'r') && (strncmp(string, "round", length) == 0)) {
+	*joinPtr = JoinRound;
+	return TCL_OK;
+    }
+
+    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+	    "bad join style \"%s\": must be bevel, miter, or round",
+	    string));
+    Tcl_SetErrorCode(interp, "TK", "VALUE", "JOIN", NULL);
+    return TCL_ERROR;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_NameOfJoinStyle --
+ *
+ *	Given a Tk JoinStyle, return the string that corresponds to it.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	None.
+ *
+ *--------------------------------------------------------------
+ */
+
+const char *
+Tk_NameOfJoinStyle(
+    int join)			/* Join style for which identifying string is
+				 * desired. */
+{
+    switch (join) {
+    case JoinBevel: return "bevel";
+    case JoinMiter: return "miter";
+    case JoinRound: return "round";
+    }
+    return "unknown join style";
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_GetCapStyle --
+ *
+ *	Given a string, return the corresponding Tk CapStyle.
+ *
+ * Results:
+ *	The return value is a standard Tcl return result. If TCL_OK is
+ *	returned, then everything went well and the justification is stored at
+ *	*capPtr; otherwise TCL_ERROR is returned and an error message is left
+ *	in the interp's result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tk_GetCapStyle(
+    Tcl_Interp *interp,		/* Use this for error reporting. */
+    const char *string,		/* String describing a justification style. */
+    int *capPtr)		/* Where to store cap style corresponding to
+				 * string. */
+{
+    int c;
+    size_t length;
+
+    c = string[0];
+    length = strlen(string);
+
+    if ((c == 'b') && (strncmp(string, "butt", length) == 0)) {
+	*capPtr = CapButt;
+	return TCL_OK;
+    }
+    if ((c == 'p') && (strncmp(string, "projecting", length) == 0)) {
+	*capPtr = CapProjecting;
+	return TCL_OK;
+    }
+    if ((c == 'r') && (strncmp(string, "round", length) == 0)) {
+	*capPtr = CapRound;
+	return TCL_OK;
+    }
+
+    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+	    "bad cap style \"%s\": must be butt, projecting, or round",
+	    string));
+    Tcl_SetErrorCode(interp, "TK", "VALUE", "CAP", NULL);
+    return TCL_ERROR;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_NameOfCapStyle --
+ *
+ *	Given a Tk CapStyle, return the string that corresponds to it.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	None.
+ *
+ *--------------------------------------------------------------
+ */
+
+const char *
+Tk_NameOfCapStyle(
+    int cap)			/* Cap style for which identifying string is
+				 * desired. */
+{
+    switch (cap) {
+    case CapButt: return "butt";
+    case CapProjecting: return "projecting";
+    case CapRound: return "round";
+    }
+    return "unknown cap style";
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_GetJustifyFromObj --
+ *
+ *	Return a Tk_Justify value based on the value of the 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:
+ *	The object gets converted by Tcl_GetIndexFromObj.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tk_GetJustifyFromObj(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    Tcl_Obj *objPtr,		/* The object we are trying to get the value
+				 * from. */
+    Tk_Justify *justifyPtr)	/* Where to place the Tk_Justify that
+				 * corresponds to the string value of
+				 * objPtr. */
+{
+    int index, code;
+
+    code = Tcl_GetIndexFromObj(interp, objPtr, justifyStrings,
+	    "justification", 0, &index);
+    if (code == TCL_OK) {
+	*justifyPtr = (Tk_Justify) index;
+    }
+    return code;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_GetJustify --
+ *
+ *	Given a string, return the corresponding Tk_Justify.
+ *
+ * Results:
+ *	The return value is a standard Tcl return result. If TCL_OK is
+ *	returned, then everything went well and the justification is stored at
+ *	*justifyPtr; otherwise TCL_ERROR is returned and an error message is
+ *	left in the interp's result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tk_GetJustify(
+    Tcl_Interp *interp,		/* Use this for error reporting. */
+    const char *string,		/* String describing a justification style. */
+    Tk_Justify *justifyPtr)	/* Where to store Tk_Justify corresponding to
+				 * string. */
+{
+    int c;
+    size_t length;
+
+    c = string[0];
+    length = strlen(string);
+
+    if ((c == 'l') && (strncmp(string, "left", length) == 0)) {
+	*justifyPtr = TK_JUSTIFY_LEFT;
+	return TCL_OK;
+    }
+    if ((c == 'r') && (strncmp(string, "right", length) == 0)) {
+	*justifyPtr = TK_JUSTIFY_RIGHT;
+	return TCL_OK;
+    }
+    if ((c == 'c') && (strncmp(string, "center", length) == 0)) {
+	*justifyPtr = TK_JUSTIFY_CENTER;
+	return TCL_OK;
+    }
+
+    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+	    "bad justification \"%s\": must be left, right, or center",
+	    string));
+    Tcl_SetErrorCode(interp, "TK", "VALUE", "JUSTIFY", NULL);
+    return TCL_ERROR;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_NameOfJustify --
+ *
+ *	Given a Tk_Justify, return the string that corresponds
+ *	to it.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	None.
+ *
+ *--------------------------------------------------------------
+ */
+
+const char *
+Tk_NameOfJustify(
+    Tk_Justify justify)		/* Justification style for which identifying
+				 * string is desired. */
+{
+    switch (justify) {
+    case TK_JUSTIFY_LEFT: return "left";
+    case TK_JUSTIFY_RIGHT: return "right";
+    case TK_JUSTIFY_CENTER: return "center";
+    }
+    return "unknown justification style";
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeUidThreadExitProc --
+ *
+ *	Cleans up memory used for Tk_Uids in the thread.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	All information in the identifier table is deleted.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeUidThreadExitProc(
+    ClientData clientData)		/* Not used. */
+{
+    ThreadSpecificData *tsdPtr =
+            Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
+
+    Tcl_DeleteHashTable(&tsdPtr->uidTable);
+    tsdPtr->initialized = 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_GetUid --
+ *
+ *	Given a string, this function returns a unique identifier for the
+ *	string.
+ *
+ * Results:
+ *	This function returns a Tk_Uid corresponding to the "string" argument.
+ *	The Tk_Uid has a string value identical to string (strcmp will return
+ *	0), but it's guaranteed that any other calls to this function with a
+ *	string equal to "string" will return exactly the same result (i.e. can
+ *	compare Tk_Uid *values* directly, without having to call strcmp on
+ *	what they point to).
+ *
+ * Side effects:
+ *	New information may be entered into the identifier table.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tk_Uid
+Tk_GetUid(
+    const char *string)		/* String to convert. */
+{
+    int dummy;
+    ThreadSpecificData *tsdPtr =
+            Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
+    Tcl_HashTable *tablePtr = &tsdPtr->uidTable;
+
+    if (!tsdPtr->initialized) {
+	Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
+	Tcl_CreateThreadExitHandler(FreeUidThreadExitProc, NULL);
+	tsdPtr->initialized = 1;
+    }
+    return (Tk_Uid) Tcl_GetHashKey(tablePtr,
+	    Tcl_CreateHashEntry(tablePtr, string, &dummy));
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_GetScreenMM --
+ *
+ *	Given a string, returns the number of screen millimeters corresponding
+ *	to that string.
+ *
+ * Results:
+ *	The return value is a standard Tcl return result. If TCL_OK is
+ *	returned, then everything went well and the screen distance is stored
+ *	at *doublePtr; otherwise TCL_ERROR is returned and an error message is
+ *	left in the interp's result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tk_GetScreenMM(
+    Tcl_Interp *interp,		/* Use this for error reporting. */
+    Tk_Window tkwin,		/* Window whose screen determines conversion
+				 * from centimeters and other absolute
+				 * units. */
+    const char *string,		/* String describing a screen distance. */
+    double *doublePtr)		/* Place to store converted result. */
+{
+    char *end;
+    double d;
+
+    d = strtod(string, &end);
+    if (end == string) {
+	goto error;
+    }
+    while ((*end != '\0') && isspace(UCHAR(*end))) {
+	end++;
+    }
+    switch (*end) {
+    case 0:
+	d /= WidthOfScreen(Tk_Screen(tkwin));
+	d *= WidthMMOfScreen(Tk_Screen(tkwin));
+	break;
+    case 'c':
+	d *= 10;
+	end++;
+	break;
+    case 'i':
+	d *= 25.4;
+	end++;
+	break;
+    case 'm':
+	end++;
+	break;
+    case 'p':
+	d *= 25.4/72.0;
+	end++;
+	break;
+    default:
+	goto error;
+    }
+    while ((*end != '\0') && isspace(UCHAR(*end))) {
+	end++;
+    }
+    if (*end != 0) {
+	goto error;
+    }
+    *doublePtr = d;
+    return TCL_OK;
+
+  error:
+    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+	    "bad screen distance \"%s\"", string));
+    Tcl_SetErrorCode(interp, "TK", "VALUE", "SCREEN_DISTANCE", NULL);
+    return TCL_ERROR;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_GetPixels --
+ *
+ *	Given a string, returns the number of pixels corresponding to that
+ *	string.
+ *
+ * Results:
+ *	The return value is a standard Tcl return result. If TCL_OK is
+ *	returned, then everything went well and the rounded pixel distance is
+ *	stored at *intPtr; otherwise TCL_ERROR is returned and an error
+ *	message is left in the interp's result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tk_GetPixels(
+    Tcl_Interp *interp,		/* Use this for error reporting. */
+    Tk_Window tkwin,		/* Window whose screen determines conversion
+				 * from centimeters and other absolute
+				 * units. */
+    const char *string,		/* String describing a number of pixels. */
+    int *intPtr)		/* Place to store converted result. */
+{
+    double d;
+
+    if (TkGetDoublePixels(interp, tkwin, string, &d) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    if (d < 0) {
+	*intPtr = (int) (d - 0.5);
+    } else {
+	*intPtr = (int) (d + 0.5);
+    }
+    return TCL_OK;
+}
+/*
+ *--------------------------------------------------------------
+ *
+ * TkGetDoublePixels --
+ *
+ *	Given a string, returns the number of pixels corresponding to that
+ *	string.
+ *
+ * Results:
+ *	The return value is a standard Tcl return result. If TCL_OK is
+ *	returned, then everything went well and the pixel distance is stored
+ *	at *doublePtr; otherwise TCL_ERROR is returned and an error message is
+ *	left in interp->result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+TkGetDoublePixels(
+    Tcl_Interp *interp,		/* Use this for error reporting. */
+    Tk_Window tkwin,		/* Window whose screen determines conversion
+				 * from centimeters and other absolute
+				 * units. */
+    const char *string,		/* String describing a number of pixels. */
+    double *doublePtr)		/* Place to store converted result. */
+{
+    char *end;
+    double d;
+
+    d = strtod((char *) string, &end);
+    if (end == string) {
+	goto error;
+    }
+    while ((*end != '\0') && isspace(UCHAR(*end))) {
+	end++;
+    }
+    switch (*end) {
+    case 0:
+	break;
+    case 'c':
+	d *= 10*WidthOfScreen(Tk_Screen(tkwin));
+	d /= WidthMMOfScreen(Tk_Screen(tkwin));
+	end++;
+	break;
+    case 'i':
+	d *= 25.4*WidthOfScreen(Tk_Screen(tkwin));
+	d /= WidthMMOfScreen(Tk_Screen(tkwin));
+	end++;
+	break;
+    case 'm':
+	d *= WidthOfScreen(Tk_Screen(tkwin));
+	d /= WidthMMOfScreen(Tk_Screen(tkwin));
+	end++;
+	break;
+    case 'p':
+	d *= (25.4/72.0)*WidthOfScreen(Tk_Screen(tkwin));
+	d /= WidthMMOfScreen(Tk_Screen(tkwin));
+	end++;
+	break;
+    default:
+	goto error;
+    }
+    while ((*end != '\0') && isspace(UCHAR(*end))) {
+	end++;
+    }
+    if (*end != 0) {
+	goto error;
+    }
+    *doublePtr = d;
+    return TCL_OK;
+
+  error:
+    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+	    "bad screen distance \"%s\"", string));
+    Tcl_SetErrorCode(interp, "TK", "VALUE", "FRACTIONAL_PIXELS", NULL);
+    return TCL_ERROR;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */