diff options
Diffstat (limited to 'tk8.6/generic/tkGet.c')
| -rw-r--r-- | tk8.6/generic/tkGet.c | 752 |
1 files changed, 0 insertions, 752 deletions
diff --git a/tk8.6/generic/tkGet.c b/tk8.6/generic/tkGet.c deleted file mode 100644 index d58b4a5..0000000 --- a/tk8.6/generic/tkGet.c +++ /dev/null @@ -1,752 +0,0 @@ -/* - * 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: - */ |