diff options
Diffstat (limited to 'tk8.6/generic/tkCmds.c')
| -rw-r--r-- | tk8.6/generic/tkCmds.c | 2163 |
1 files changed, 2163 insertions, 0 deletions
diff --git a/tk8.6/generic/tkCmds.c b/tk8.6/generic/tkCmds.c new file mode 100644 index 0000000..6196b17 --- /dev/null +++ b/tk8.6/generic/tkCmds.c @@ -0,0 +1,2163 @@ +/* + * tkCmds.c -- + * + * This file contains a collection of Tk-related Tcl commands that didn't + * fit in any particular file of the toolkit. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 2000 Scriptics Corporation. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tkInt.h" + +#if defined(_WIN32) +#include "tkWinInt.h" +#elif defined(MAC_OSX_TK) +#include "tkMacOSXInt.h" +#else +#include "tkUnixInt.h" +#endif + +/* + * Forward declarations for functions defined later in this file: + */ + +static TkWindow * GetTopHierarchy(Tk_Window tkwin); +static char * WaitVariableProc(ClientData clientData, + Tcl_Interp *interp, const char *name1, + const char *name2, int flags); +static void WaitVisibilityProc(ClientData clientData, + XEvent *eventPtr); +static void WaitWindowProc(ClientData clientData, + XEvent *eventPtr); +static int AppnameCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int CaretCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int InactiveCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int ScalingCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int UseinputmethodsCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +static int WindowingsystemCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); + +#if defined(_WIN32) || defined(MAC_OSX_TK) +MODULE_SCOPE const TkEnsemble tkFontchooserEnsemble[]; +#else +#define tkFontchooserEnsemble NULL +#endif + +/* + * Table of tk subcommand names and implementations. + */ + +static const TkEnsemble tkCmdMap[] = { + {"appname", AppnameCmd, NULL }, + {"busy", Tk_BusyObjCmd, NULL }, + {"caret", CaretCmd, NULL }, + {"inactive", InactiveCmd, NULL }, + {"scaling", ScalingCmd, NULL }, + {"useinputmethods", UseinputmethodsCmd, NULL }, + {"windowingsystem", WindowingsystemCmd, NULL }, + {"fontchooser", NULL, tkFontchooserEnsemble}, + {NULL, NULL, NULL} +}; + +/* + *---------------------------------------------------------------------- + * + * Tk_BellObjCmd -- + * + * This function is invoked to process the "bell" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tk_BellObjCmd( + ClientData clientData, /* Main window associated with interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *const bellOptions[] = { + "-displayof", "-nice", NULL + }; + enum options { TK_BELL_DISPLAYOF, TK_BELL_NICE }; + Tk_Window tkwin = clientData; + int i, index, nice = 0; + + if (objc > 4) { + wrongArgs: + Tcl_WrongNumArgs(interp, 1, objv, "?-displayof window? ?-nice?"); + return TCL_ERROR; + } + + for (i = 1; i < objc; i++) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], bellOptions, + sizeof(char *), "option", 0, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum options) index) { + case TK_BELL_DISPLAYOF: + if (++i >= objc) { + goto wrongArgs; + } + tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[i]), tkwin); + if (tkwin == NULL) { + return TCL_ERROR; + } + break; + case TK_BELL_NICE: + nice = 1; + break; + } + } + XBell(Tk_Display(tkwin), 0); + if (!nice) { + XForceScreenSaver(Tk_Display(tkwin), ScreenSaverReset); + } + XFlush(Tk_Display(tkwin)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_BindObjCmd -- + * + * This function is invoked to process the "bind" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tk_BindObjCmd( + ClientData clientData, /* Main window associated with interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tk_Window tkwin = clientData; + TkWindow *winPtr; + ClientData object; + const char *string; + + if ((objc < 2) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 1, objv, "window ?pattern? ?command?"); + return TCL_ERROR; + } + string = Tcl_GetString(objv[1]); + + /* + * Bind tags either a window name or a tag name for the first argument. + * If the argument starts with ".", assume it is a window; otherwise, it + * is a tag. + */ + + if (string[0] == '.') { + winPtr = (TkWindow *) Tk_NameToWindow(interp, string, tkwin); + if (winPtr == NULL) { + return TCL_ERROR; + } + object = (ClientData) winPtr->pathName; + } else { + winPtr = clientData; + object = (ClientData) Tk_GetUid(string); + } + + /* + * If there are four arguments, the command is modifying a binding. If + * there are three arguments, the command is querying a binding. If there + * are only two arguments, the command is querying all the bindings for + * the given tag/window. + */ + + if (objc == 4) { + int append = 0; + unsigned long mask; + const char *sequence = Tcl_GetString(objv[2]); + const char *script = Tcl_GetString(objv[3]); + + /* + * If the script is null, just delete the binding. + */ + + if (script[0] == 0) { + return Tk_DeleteBinding(interp, winPtr->mainPtr->bindingTable, + object, sequence); + } + + /* + * If the script begins with "+", append this script to the existing + * binding. + */ + + if (script[0] == '+') { + script++; + append = 1; + } + mask = Tk_CreateBinding(interp, winPtr->mainPtr->bindingTable, + object, sequence, script, append); + if (mask == 0) { + return TCL_ERROR; + } + } else if (objc == 3) { + const char *command; + + command = Tk_GetBinding(interp, winPtr->mainPtr->bindingTable, + object, Tcl_GetString(objv[2])); + if (command == NULL) { + Tcl_ResetResult(interp); + return TCL_OK; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(command, -1)); + } else { + Tk_GetAllBindings(interp, winPtr->mainPtr->bindingTable, object); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TkBindEventProc -- + * + * This function is invoked by Tk_HandleEvent for each event; it causes + * any appropriate bindings for that event to be invoked. + * + * Results: + * None. + * + * Side effects: + * Depends on what bindings have been established with the "bind" + * command. + * + *---------------------------------------------------------------------- + */ + +void +TkBindEventProc( + TkWindow *winPtr, /* Pointer to info about window. */ + XEvent *eventPtr) /* Information about event. */ +{ +#define MAX_OBJS 20 + ClientData objects[MAX_OBJS], *objPtr; + TkWindow *topLevPtr; + int i, count; + const char *p; + Tcl_HashEntry *hPtr; + + if ((winPtr->mainPtr == NULL) || (winPtr->mainPtr->bindingTable == NULL)) { + return; + } + + objPtr = objects; + if (winPtr->numTags != 0) { + /* + * Make a copy of the tags for the window, replacing window names with + * pointers to the pathName from the appropriate window. + */ + + if (winPtr->numTags > MAX_OBJS) { + objPtr = ckalloc(winPtr->numTags * sizeof(ClientData)); + } + for (i = 0; i < winPtr->numTags; i++) { + p = winPtr->tagPtr[i]; + if (*p == '.') { + hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->nameTable, p); + if (hPtr != NULL) { + p = ((TkWindow *) Tcl_GetHashValue(hPtr))->pathName; + } else { + p = NULL; + } + } + objPtr[i] = (ClientData) p; + } + count = winPtr->numTags; + } else { + objPtr[0] = (ClientData) winPtr->pathName; + objPtr[1] = (ClientData) winPtr->classUid; + for (topLevPtr = winPtr; + (topLevPtr != NULL) && !(topLevPtr->flags & TK_TOP_HIERARCHY); + topLevPtr = topLevPtr->parentPtr) { + /* Empty loop body. */ + } + if ((winPtr != topLevPtr) && (topLevPtr != NULL)) { + count = 4; + objPtr[2] = (ClientData) topLevPtr->pathName; + } else { + count = 3; + } + objPtr[count-1] = (ClientData) Tk_GetUid("all"); + } + Tk_BindEvent(winPtr->mainPtr->bindingTable, eventPtr, (Tk_Window) winPtr, + count, objPtr); + if (objPtr != objects) { + ckfree(objPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_BindtagsObjCmd -- + * + * This function is invoked to process the "bindtags" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tk_BindtagsObjCmd( + ClientData clientData, /* Main window associated with interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tk_Window tkwin = clientData; + TkWindow *winPtr, *winPtr2; + int i, length; + const char *p; + Tcl_Obj *listPtr, **tags; + + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "window ?taglist?"); + return TCL_ERROR; + } + winPtr = (TkWindow *) Tk_NameToWindow(interp, Tcl_GetString(objv[1]), + tkwin); + if (winPtr == NULL) { + return TCL_ERROR; + } + if (objc == 2) { + listPtr = Tcl_NewObj(); + if (winPtr->numTags == 0) { + Tcl_ListObjAppendElement(NULL, listPtr, + Tcl_NewStringObj(winPtr->pathName, -1)); + Tcl_ListObjAppendElement(NULL, listPtr, + Tcl_NewStringObj(winPtr->classUid, -1)); + winPtr2 = winPtr; + while ((winPtr2 != NULL) && !(Tk_TopWinHierarchy(winPtr2))) { + winPtr2 = winPtr2->parentPtr; + } + if ((winPtr != winPtr2) && (winPtr2 != NULL)) { + Tcl_ListObjAppendElement(NULL, listPtr, + Tcl_NewStringObj(winPtr2->pathName, -1)); + } + Tcl_ListObjAppendElement(NULL, listPtr, + Tcl_NewStringObj("all", -1)); + } else { + for (i = 0; i < winPtr->numTags; i++) { + Tcl_ListObjAppendElement(NULL, listPtr, + Tcl_NewStringObj((char *) winPtr->tagPtr[i], -1)); + } + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; + } + if (winPtr->tagPtr != NULL) { + TkFreeBindingTags(winPtr); + } + if (Tcl_ListObjGetElements(interp, objv[2], &length, &tags) != TCL_OK) { + return TCL_ERROR; + } + if (length == 0) { + return TCL_OK; + } + + winPtr->numTags = length; + winPtr->tagPtr = ckalloc(length * sizeof(ClientData)); + for (i = 0; i < length; i++) { + p = Tcl_GetString(tags[i]); + if (p[0] == '.') { + char *copy; + + /* + * Handle names starting with "." specially: store a malloc'ed + * string, rather than a Uid; at event time we'll look up the name + * in the window table and use the corresponding window, if there + * is one. + */ + + copy = ckalloc(strlen(p) + 1); + strcpy(copy, p); + winPtr->tagPtr[i] = (ClientData) copy; + } else { + winPtr->tagPtr[i] = (ClientData) Tk_GetUid(p); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TkFreeBindingTags -- + * + * This function is called to free all of the binding tags associated + * with a window; typically it is only invoked where there are + * window-specific tags. + * + * Results: + * None. + * + * Side effects: + * Any binding tags for winPtr are freed. + * + *---------------------------------------------------------------------- + */ + +void +TkFreeBindingTags( + TkWindow *winPtr) /* Window whose tags are to be released. */ +{ + int i; + const char *p; + + for (i = 0; i < winPtr->numTags; i++) { + p = winPtr->tagPtr[i]; + if (*p == '.') { + /* + * Names starting with "." are malloced rather than Uids, so they + * have to be freed. + */ + + ckfree((char *)p); + } + } + ckfree(winPtr->tagPtr); + winPtr->numTags = 0; + winPtr->tagPtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_DestroyObjCmd -- + * + * This function is invoked to process the "destroy" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tk_DestroyObjCmd( + ClientData clientData, /* Main window associated with interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tk_Window window; + Tk_Window tkwin = clientData; + int i; + + for (i = 1; i < objc; i++) { + window = Tk_NameToWindow(interp, Tcl_GetString(objv[i]), tkwin); + if (window == NULL) { + Tcl_ResetResult(interp); + continue; + } + Tk_DestroyWindow(window); + if (window == tkwin) { + /* + * We just deleted the main window for the application! This makes + * it impossible to do anything more (tkwin isn't valid anymore). + */ + + break; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_LowerObjCmd -- + * + * This function is invoked to process the "lower" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tk_LowerObjCmd( + ClientData clientData, /* Main window associated with interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tk_Window mainwin = clientData; + Tk_Window tkwin, other; + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "window ?belowThis?"); + return TCL_ERROR; + } + + tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[1]), mainwin); + if (tkwin == NULL) { + return TCL_ERROR; + } + if (objc == 2) { + other = NULL; + } else { + other = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), mainwin); + if (other == NULL) { + return TCL_ERROR; + } + } + if (Tk_RestackWindow(tkwin, Below, other) != TCL_OK) { + if (other) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't lower \"%s\" below \"%s\"", + Tcl_GetString(objv[1]), Tcl_GetString(objv[2]))); + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't lower \"%s\" to bottom", Tcl_GetString(objv[1]))); + } + Tcl_SetErrorCode(interp, "TK", "RESTACK", "LOWER", NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_RaiseObjCmd -- + * + * This function is invoked to process the "raise" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tk_RaiseObjCmd( + ClientData clientData, /* Main window associated with interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tk_Window mainwin = clientData; + Tk_Window tkwin, other; + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "window ?aboveThis?"); + return TCL_ERROR; + } + + tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[1]), mainwin); + if (tkwin == NULL) { + return TCL_ERROR; + } + if (objc == 2) { + other = NULL; + } else { + other = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), mainwin); + if (other == NULL) { + return TCL_ERROR; + } + } + if (Tk_RestackWindow(tkwin, Above, other) != TCL_OK) { + if (other) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't raise \"%s\" above \"%s\"", + Tcl_GetString(objv[1]), Tcl_GetString(objv[2]))); + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't raise \"%s\" to top", Tcl_GetString(objv[1]))); + } + Tcl_SetErrorCode(interp, "TK", "RESTACK", "RAISE", NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TkInitTkCmd -- + * + * Set up the tk ensemble. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + * ---------------------------------------------------------------------- + */ + +int +TkInitTkCmd( + Tcl_Interp *interp, + ClientData clientData) +{ + TkMakeEnsemble(interp, "::", "tk", clientData, tkCmdMap); +#if defined(_WIN32) || defined(MAC_OSX_TK) + TkInitFontchooser(interp, clientData); +#endif + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * AppnameCmd, CaretCmd, ScalingCmd, UseinputmethodsCmd, + * WindowingsystemCmd, InactiveCmd -- + * + * These functions are invoked to process the "tk" ensemble subcommands. + * See the user documentation for details on what they do. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +AppnameCmd( + ClientData clientData, /* Main window associated with interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tk_Window tkwin = clientData; + TkWindow *winPtr; + const char *string; + + if (Tcl_IsSafe(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "appname not accessible in a safe interpreter", -1)); + Tcl_SetErrorCode(interp, "TK", "SAFE", "APPLICATION", NULL); + return TCL_ERROR; + } + + winPtr = (TkWindow *) tkwin; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?newName?"); + return TCL_ERROR; + } + if (objc == 2) { + string = Tcl_GetString(objv[1]); + winPtr->nameUid = Tk_GetUid(Tk_SetAppName(tkwin, string)); + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(winPtr->nameUid, -1)); + return TCL_OK; +} + +int +CaretCmd( + ClientData clientData, /* Main window associated with interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tk_Window tkwin = clientData; + int index; + Tcl_Obj *objPtr; + TkCaret *caretPtr; + Tk_Window window; + static const char *const caretStrings[] = { + "-x", "-y", "-height", NULL + }; + enum caretOptions { + TK_CARET_X, TK_CARET_Y, TK_CARET_HEIGHT + }; + + if ((objc < 2) || ((objc > 3) && !!(objc & 1))) { + Tcl_WrongNumArgs(interp, 1, objv, + "window ?-x x? ?-y y? ?-height height?"); + return TCL_ERROR; + } + window = Tk_NameToWindow(interp, Tcl_GetString(objv[1]), tkwin); + if (window == NULL) { + return TCL_ERROR; + } + caretPtr = &(((TkWindow *) window)->dispPtr->caret); + if (objc == 2) { + /* + * Return all the current values + */ + + objPtr = Tcl_NewObj(); + Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewStringObj("-height", 7)); + Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewIntObj(caretPtr->height)); + Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewStringObj("-x", 2)); + Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewIntObj(caretPtr->x)); + Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewStringObj("-y", 2)); + Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewIntObj(caretPtr->y)); + Tcl_SetObjResult(interp, objPtr); + } else if (objc == 3) { + int value; + + /* + * Return the current value of the selected option + */ + + if (Tcl_GetIndexFromObj(interp, objv[2], caretStrings, + "caret option", 0, &index) != TCL_OK) { + return TCL_ERROR; + } + if (index == TK_CARET_X) { + value = caretPtr->x; + } else if (index == TK_CARET_Y) { + value = caretPtr->y; + } else /* if (index == TK_CARET_HEIGHT) -- last case */ { + value = caretPtr->height; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(value)); + } else { + int i, value, x = 0, y = 0, height = -1; + + for (i = 2; i < objc; i += 2) { + if ((Tcl_GetIndexFromObj(interp, objv[i], caretStrings, + "caret option", 0, &index) != TCL_OK) || + Tcl_GetIntFromObj(interp,objv[i+1],&value) != TCL_OK) { + return TCL_ERROR; + } + if (index == TK_CARET_X) { + x = value; + } else if (index == TK_CARET_Y) { + y = value; + } else /* if (index == TK_CARET_HEIGHT) -- last case */ { + height = value; + } + } + if (height < 0) { + height = Tk_Height(window); + } + Tk_SetCaretPos(window, x, y, height); + } + return TCL_OK; +} + +int +ScalingCmd( + ClientData clientData, /* Main window associated with interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tk_Window tkwin = clientData; + Screen *screenPtr; + int skip, width, height; + double d; + + if (Tcl_IsSafe(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "scaling not accessible in a safe interpreter", -1)); + Tcl_SetErrorCode(interp, "TK", "SAFE", "SCALING", NULL); + return TCL_ERROR; + } + + skip = TkGetDisplayOf(interp, objc - 1, objv + 1, &tkwin); + if (skip < 0) { + return TCL_ERROR; + } + screenPtr = Tk_Screen(tkwin); + if (objc - skip == 1) { + d = 25.4 / 72; + d *= WidthOfScreen(screenPtr); + d /= WidthMMOfScreen(screenPtr); + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(d)); + } else if (objc - skip == 2) { + if (Tcl_GetDoubleFromObj(interp, objv[1+skip], &d) != TCL_OK) { + return TCL_ERROR; + } + d = (25.4 / 72) / d; + width = (int) (d * WidthOfScreen(screenPtr) + 0.5); + if (width <= 0) { + width = 1; + } + height = (int) (d * HeightOfScreen(screenPtr) + 0.5); + if (height <= 0) { + height = 1; + } + WidthMMOfScreen(screenPtr) = width; + HeightMMOfScreen(screenPtr) = height; + } else { + Tcl_WrongNumArgs(interp, 1, objv, "?-displayof window? ?factor?"); + return TCL_ERROR; + } + return TCL_OK; +} + +int +UseinputmethodsCmd( + ClientData clientData, /* Main window associated with interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tk_Window tkwin = clientData; + TkDisplay *dispPtr; + int skip; + + if (Tcl_IsSafe(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "useinputmethods not accessible in a safe interpreter", -1)); + Tcl_SetErrorCode(interp, "TK", "SAFE", "INPUT_METHODS", NULL); + return TCL_ERROR; + } + + skip = TkGetDisplayOf(interp, objc-1, objv+1, &tkwin); + if (skip < 0) { + return TCL_ERROR; + } + dispPtr = ((TkWindow *) tkwin)->dispPtr; + if ((objc - skip) == 2) { + /* + * In the case where TK_USE_INPUT_METHODS is not defined, this + * will be ignored and we will always return 0. That will indicate + * to the user that input methods are just not available. + */ + + int boolVal; + + if (Tcl_GetBooleanFromObj(interp, objv[1+skip], + &boolVal) != TCL_OK) { + return TCL_ERROR; + } +#ifdef TK_USE_INPUT_METHODS + if (boolVal) { + dispPtr->flags |= TK_DISPLAY_USE_IM; + } else { + dispPtr->flags &= ~TK_DISPLAY_USE_IM; + } +#endif /* TK_USE_INPUT_METHODS */ + } else if ((objc - skip) != 1) { + Tcl_WrongNumArgs(interp, 1, objv, + "?-displayof window? ?boolean?"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, + Tcl_NewBooleanObj(dispPtr->flags & TK_DISPLAY_USE_IM)); + return TCL_OK; +} + +int +WindowingsystemCmd( + ClientData clientData, /* Main window associated with interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + const char *windowingsystem; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } +#if defined(_WIN32) + windowingsystem = "win32"; +#elif defined(MAC_OSX_TK) + windowingsystem = "aqua"; +#else + windowingsystem = "x11"; +#endif + Tcl_SetObjResult(interp, Tcl_NewStringObj(windowingsystem, -1)); + return TCL_OK; +} + +int +InactiveCmd( + ClientData clientData, /* Main window associated with interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tk_Window tkwin = clientData; + int skip = TkGetDisplayOf(interp, objc - 1, objv + 1, &tkwin); + + if (skip < 0) { + return TCL_ERROR; + } + if (objc - skip == 1) { + long inactive; + + inactive = (Tcl_IsSafe(interp) ? -1 : + Tk_GetUserInactiveTime(Tk_Display(tkwin))); + Tcl_SetObjResult(interp, Tcl_NewLongObj(inactive)); + } else if (objc - skip == 2) { + const char *string; + + string = Tcl_GetString(objv[objc-1]); + if (strcmp(string, "reset") != 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be reset", string)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string, NULL); + return TCL_ERROR; + } + if (Tcl_IsSafe(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "resetting the user inactivity timer " + "is not allowed in a safe interpreter", -1)); + Tcl_SetErrorCode(interp, "TK", "SAFE", "INACTIVITY_TIMER", NULL); + return TCL_ERROR; + } + Tk_ResetUserInactiveTime(Tk_Display(tkwin)); + Tcl_ResetResult(interp); + } else { + Tcl_WrongNumArgs(interp, 1, objv, "?-displayof window? ?reset?"); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_TkwaitObjCmd -- + * + * This function is invoked to process the "tkwait" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tk_TkwaitObjCmd( + ClientData clientData, /* Main window associated with interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tk_Window tkwin = clientData; + int done, index; + int code = TCL_OK; + static const char *const optionStrings[] = { + "variable", "visibility", "window", NULL + }; + enum options { + TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW + }; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum options) index) { + case TKWAIT_VARIABLE: + if (Tcl_TraceVar2(interp, Tcl_GetString(objv[2]), + NULL, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + WaitVariableProc, &done) != TCL_OK) { + return TCL_ERROR; + } + done = 0; + while (!done) { + if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { + code = TCL_ERROR; + break; + } + Tcl_DoOneEvent(0); + } + Tcl_UntraceVar2(interp, Tcl_GetString(objv[2]), + NULL, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + WaitVariableProc, &done); + break; + + case TKWAIT_VISIBILITY: { + Tk_Window window; + + window = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), tkwin); + if (window == NULL) { + return TCL_ERROR; + } + Tk_CreateEventHandler(window, + VisibilityChangeMask|StructureNotifyMask, + WaitVisibilityProc, &done); + done = 0; + while (!done) { + if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { + code = TCL_ERROR; + break; + } + Tcl_DoOneEvent(0); + } + if ((done != 0) && (done != 1)) { + /* + * Note that we do not delete the event handler because it was + * deleted automatically when the window was destroyed. + */ + + Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "window \"%s\" was deleted before its visibility changed", + Tcl_GetString(objv[2]))); + Tcl_SetErrorCode(interp, "TK", "WAIT", "PREMATURE", NULL); + return TCL_ERROR; + } + Tk_DeleteEventHandler(window, + VisibilityChangeMask|StructureNotifyMask, + WaitVisibilityProc, &done); + break; + } + + case TKWAIT_WINDOW: { + Tk_Window window; + + window = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), tkwin); + if (window == NULL) { + return TCL_ERROR; + } + Tk_CreateEventHandler(window, StructureNotifyMask, + WaitWindowProc, &done); + done = 0; + while (!done) { + if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { + code = TCL_ERROR; + break; + } + Tcl_DoOneEvent(0); + } + + /* + * Note: normally there's no need to delete the event handler. It was + * deleted automatically when the window was destroyed; however, if + * the wait operation was canceled, we need to delete it. + */ + + if (done == 0) { + Tk_DeleteEventHandler(window, StructureNotifyMask, + WaitWindowProc, &done); + } + break; + } + } + + /* + * Clear out the interpreter's result, since it may have been set by event + * handlers. This is skipped if an error occurred above, such as the wait + * operation being canceled. + */ + + if (code == TCL_OK) + Tcl_ResetResult(interp); + + return code; +} + + /* ARGSUSED */ +static char * +WaitVariableProc( + ClientData clientData, /* Pointer to integer to set to 1. */ + Tcl_Interp *interp, /* Interpreter containing variable. */ + const char *name1, /* Name of variable. */ + const char *name2, /* Second part of variable name. */ + int flags) /* Information about what happened. */ +{ + int *donePtr = clientData; + + *donePtr = 1; + return NULL; +} + + /*ARGSUSED*/ +static void +WaitVisibilityProc( + ClientData clientData, /* Pointer to integer to set to 1. */ + XEvent *eventPtr) /* Information about event (not used). */ +{ + int *donePtr = clientData; + + if (eventPtr->type == VisibilityNotify) { + *donePtr = 1; + } else if (eventPtr->type == DestroyNotify) { + *donePtr = 2; + } +} + +static void +WaitWindowProc( + ClientData clientData, /* Pointer to integer to set to 1. */ + XEvent *eventPtr) /* Information about event. */ +{ + int *donePtr = clientData; + + if (eventPtr->type == DestroyNotify) { + *donePtr = 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_UpdateObjCmd -- + * + * This function is invoked to process the "update" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tk_UpdateObjCmd( + ClientData clientData, /* Main window associated with interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *const updateOptions[] = {"idletasks", NULL}; + int flags, index; + TkDisplay *dispPtr; + int code = TCL_OK; + + if (objc == 1) { + flags = TCL_DONT_WAIT; + } else if (objc == 2) { + if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + flags = TCL_IDLE_EVENTS; + } else { + Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?"); + return TCL_ERROR; + } + + /* + * Handle all pending events, sync all displays, and repeat over and over + * again until all pending events have been handled. Special note: it's + * possible that the entire application could be destroyed by an event + * handler that occurs during the update. Thus, don't use any information + * from tkwin after calling Tcl_DoOneEvent. + */ + + while (1) { + while (Tcl_DoOneEvent(flags) != 0) { + if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { + code = TCL_ERROR; + break; + } + } + + /* + * If event processing was canceled proceed no further. + */ + + if (code == TCL_ERROR) + break; + + for (dispPtr = TkGetDisplayList(); dispPtr != NULL; + dispPtr = dispPtr->nextPtr) { + XSync(dispPtr->display, False); + } + + /* + * Check again if event processing has been canceled because the inner + * loop (above) may not have checked (i.e. no events were processed and + * the loop body was skipped). + */ + + if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { + code = TCL_ERROR; + break; + } + + if (Tcl_DoOneEvent(flags) == 0) { + break; + } + } + + /* + * Must clear the interpreter's result because event handlers could have + * executed commands. This is skipped if an error occurred above, such as + * the wait operation being canceled. + */ + + if (code == TCL_OK) + Tcl_ResetResult(interp); + + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_WinfoObjCmd -- + * + * This function is invoked to process the "winfo" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tk_WinfoObjCmd( + ClientData clientData, /* Main window associated with interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int index, x, y, width, height, useX, useY, class, skip; + const char *string; + TkWindow *winPtr; + Tk_Window tkwin = clientData; + + static const TkStateMap visualMap[] = { + {PseudoColor, "pseudocolor"}, + {GrayScale, "grayscale"}, + {DirectColor, "directcolor"}, + {TrueColor, "truecolor"}, + {StaticColor, "staticcolor"}, + {StaticGray, "staticgray"}, + {-1, NULL} + }; + static const char *const optionStrings[] = { + "cells", "children", "class", "colormapfull", + "depth", "geometry", "height", "id", + "ismapped", "manager", "name", "parent", + "pointerx", "pointery", "pointerxy", "reqheight", + "reqwidth", "rootx", "rooty", "screen", + "screencells", "screendepth", "screenheight", "screenwidth", + "screenmmheight","screenmmwidth","screenvisual","server", + "toplevel", "viewable", "visual", "visualid", + "vrootheight", "vrootwidth", "vrootx", "vrooty", + "width", "x", "y", + + "atom", "atomname", "containing", "interps", + "pathname", + + "exists", "fpixels", "pixels", "rgb", + "visualsavailable", + + NULL + }; + enum options { + WIN_CELLS, WIN_CHILDREN, WIN_CLASS, WIN_COLORMAPFULL, + WIN_DEPTH, WIN_GEOMETRY, WIN_HEIGHT, WIN_ID, + WIN_ISMAPPED, WIN_MANAGER, WIN_NAME, WIN_PARENT, + WIN_POINTERX, WIN_POINTERY, WIN_POINTERXY, WIN_REQHEIGHT, + WIN_REQWIDTH, WIN_ROOTX, WIN_ROOTY, WIN_SCREEN, + WIN_SCREENCELLS,WIN_SCREENDEPTH,WIN_SCREENHEIGHT,WIN_SCREENWIDTH, + WIN_SCREENMMHEIGHT,WIN_SCREENMMWIDTH,WIN_SCREENVISUAL,WIN_SERVER, + WIN_TOPLEVEL, WIN_VIEWABLE, WIN_VISUAL, WIN_VISUALID, + WIN_VROOTHEIGHT,WIN_VROOTWIDTH, WIN_VROOTX, WIN_VROOTY, + WIN_WIDTH, WIN_X, WIN_Y, + + WIN_ATOM, WIN_ATOMNAME, WIN_CONTAINING, WIN_INTERPS, + WIN_PATHNAME, + + WIN_EXISTS, WIN_FPIXELS, WIN_PIXELS, WIN_RGB, + WIN_VISUALSAVAILABLE + }; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + if (index < WIN_ATOM) { + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "window"); + return TCL_ERROR; + } + string = Tcl_GetString(objv[2]); + tkwin = Tk_NameToWindow(interp, string, tkwin); + if (tkwin == NULL) { + return TCL_ERROR; + } + } + winPtr = (TkWindow *) tkwin; + + switch ((enum options) index) { + case WIN_CELLS: + Tcl_SetObjResult(interp, + Tcl_NewIntObj(Tk_Visual(tkwin)->map_entries)); + break; + case WIN_CHILDREN: { + Tcl_Obj *strPtr, *resultPtr = Tcl_NewObj(); + + winPtr = winPtr->childList; + for ( ; winPtr != NULL; winPtr = winPtr->nextPtr) { + if (!(winPtr->flags & TK_ANONYMOUS_WINDOW)) { + strPtr = Tcl_NewStringObj(winPtr->pathName, -1); + Tcl_ListObjAppendElement(NULL, resultPtr, strPtr); + } + } + Tcl_SetObjResult(interp, resultPtr); + break; + } + case WIN_CLASS: + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tk_Class(tkwin), -1)); + break; + case WIN_COLORMAPFULL: + Tcl_SetObjResult(interp, + Tcl_NewBooleanObj(TkpCmapStressed(tkwin,Tk_Colormap(tkwin)))); + break; + case WIN_DEPTH: + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tk_Depth(tkwin))); + break; + case WIN_GEOMETRY: + Tcl_SetObjResult(interp, Tcl_ObjPrintf("%dx%d+%d+%d", + Tk_Width(tkwin), Tk_Height(tkwin), Tk_X(tkwin), Tk_Y(tkwin))); + break; + case WIN_HEIGHT: + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tk_Height(tkwin))); + break; + case WIN_ID: { + char buf[TCL_INTEGER_SPACE]; + + Tk_MakeWindowExist(tkwin); + TkpPrintWindowId(buf, Tk_WindowId(tkwin)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1)); + break; + } + case WIN_ISMAPPED: + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tk_IsMapped(tkwin))); + break; + case WIN_MANAGER: + if (winPtr->geomMgrPtr != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj(winPtr->geomMgrPtr->name, -1)); + } + break; + case WIN_NAME: + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tk_Name(tkwin), -1)); + break; + case WIN_PARENT: + if (winPtr->parentPtr != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj(winPtr->parentPtr->pathName, -1)); + } + break; + case WIN_POINTERX: + useX = 1; + useY = 0; + goto pointerxy; + case WIN_POINTERY: + useX = 0; + useY = 1; + goto pointerxy; + case WIN_POINTERXY: + useX = 1; + useY = 1; + + pointerxy: + winPtr = GetTopHierarchy(tkwin); + if (winPtr == NULL) { + x = -1; + y = -1; + } else { + TkGetPointerCoords((Tk_Window) winPtr, &x, &y); + } + if (useX & useY) { + Tcl_Obj *xyObj[2]; + + xyObj[0] = Tcl_NewIntObj(x); + xyObj[1] = Tcl_NewIntObj(y); + Tcl_SetObjResult(interp, Tcl_NewListObj(2, xyObj)); + } else if (useX) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(x)); + } else { + Tcl_SetObjResult(interp, Tcl_NewIntObj(y)); + } + break; + case WIN_REQHEIGHT: + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tk_ReqHeight(tkwin))); + break; + case WIN_REQWIDTH: + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tk_ReqWidth(tkwin))); + break; + case WIN_ROOTX: + Tk_GetRootCoords(tkwin, &x, &y); + Tcl_SetObjResult(interp, Tcl_NewIntObj(x)); + break; + case WIN_ROOTY: + Tk_GetRootCoords(tkwin, &x, &y); + Tcl_SetObjResult(interp, Tcl_NewIntObj(y)); + break; + case WIN_SCREEN: + Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s.%d", + Tk_DisplayName(tkwin), Tk_ScreenNumber(tkwin))); + break; + case WIN_SCREENCELLS: + Tcl_SetObjResult(interp, + Tcl_NewIntObj(CellsOfScreen(Tk_Screen(tkwin)))); + break; + case WIN_SCREENDEPTH: + Tcl_SetObjResult(interp, + Tcl_NewIntObj(DefaultDepthOfScreen(Tk_Screen(tkwin)))); + break; + case WIN_SCREENHEIGHT: + Tcl_SetObjResult(interp, + Tcl_NewIntObj(HeightOfScreen(Tk_Screen(tkwin)))); + break; + case WIN_SCREENWIDTH: + Tcl_SetObjResult(interp, + Tcl_NewIntObj(WidthOfScreen(Tk_Screen(tkwin)))); + break; + case WIN_SCREENMMHEIGHT: + Tcl_SetObjResult(interp, + Tcl_NewIntObj(HeightMMOfScreen(Tk_Screen(tkwin)))); + break; + case WIN_SCREENMMWIDTH: + Tcl_SetObjResult(interp, + Tcl_NewIntObj(WidthMMOfScreen(Tk_Screen(tkwin)))); + break; + case WIN_SCREENVISUAL: + class = DefaultVisualOfScreen(Tk_Screen(tkwin))->class; + goto visual; + case WIN_SERVER: + TkGetServerInfo(interp, tkwin); + break; + case WIN_TOPLEVEL: + winPtr = GetTopHierarchy(tkwin); + if (winPtr != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(winPtr->pathName, -1)); + } + break; + case WIN_VIEWABLE: { + int viewable = 0; + + for ( ; ; winPtr = winPtr->parentPtr) { + if ((winPtr == NULL) || !(winPtr->flags & TK_MAPPED)) { + break; + } + if (winPtr->flags & TK_TOP_HIERARCHY) { + viewable = 1; + break; + } + } + + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(viewable)); + break; + } + case WIN_VISUAL: + class = Tk_Visual(tkwin)->class; + + visual: + string = TkFindStateString(visualMap, class); + if (string == NULL) { + string = "unknown"; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(string, -1)); + break; + case WIN_VISUALID: + Tcl_SetObjResult(interp, Tcl_ObjPrintf("0x%x", (unsigned) + XVisualIDFromVisual(Tk_Visual(tkwin)))); + break; + case WIN_VROOTHEIGHT: + Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height); + Tcl_SetObjResult(interp, Tcl_NewIntObj(height)); + break; + case WIN_VROOTWIDTH: + Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height); + Tcl_SetObjResult(interp, Tcl_NewIntObj(width)); + break; + case WIN_VROOTX: + Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height); + Tcl_SetObjResult(interp, Tcl_NewIntObj(x)); + break; + case WIN_VROOTY: + Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height); + Tcl_SetObjResult(interp, Tcl_NewIntObj(y)); + break; + case WIN_WIDTH: + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tk_Width(tkwin))); + break; + case WIN_X: + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tk_X(tkwin))); + break; + case WIN_Y: + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tk_Y(tkwin))); + break; + + /* + * Uses -displayof. + */ + + case WIN_ATOM: + skip = TkGetDisplayOf(interp, objc - 2, objv + 2, &tkwin); + if (skip < 0) { + return TCL_ERROR; + } + if (objc - skip != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?-displayof window? name"); + return TCL_ERROR; + } + objv += skip; + string = Tcl_GetString(objv[2]); + Tcl_SetObjResult(interp, + Tcl_NewLongObj((long) Tk_InternAtom(tkwin, string))); + break; + case WIN_ATOMNAME: { + const char *name; + long id; + + skip = TkGetDisplayOf(interp, objc - 2, objv + 2, &tkwin); + if (skip < 0) { + return TCL_ERROR; + } + if (objc - skip != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?-displayof window? id"); + return TCL_ERROR; + } + objv += skip; + if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) { + return TCL_ERROR; + } + name = Tk_GetAtomName(tkwin, (Atom) id); + if (strcmp(name, "?bad atom?") == 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no atom exists with id \"%s\"", Tcl_GetString(objv[2]))); + Tcl_SetErrorCode(interp, "TK", "LOOKUP", "ATOM", + Tcl_GetString(objv[2]), NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1)); + break; + } + case WIN_CONTAINING: + skip = TkGetDisplayOf(interp, objc - 2, objv + 2, &tkwin); + if (skip < 0) { + return TCL_ERROR; + } + if (objc - skip != 4) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-displayof window? rootX rootY"); + return TCL_ERROR; + } + objv += skip; + string = Tcl_GetString(objv[2]); + if (Tk_GetPixels(interp, tkwin, string, &x) != TCL_OK) { + return TCL_ERROR; + } + string = Tcl_GetString(objv[3]); + if (Tk_GetPixels(interp, tkwin, string, &y) != TCL_OK) { + return TCL_ERROR; + } + tkwin = Tk_CoordsToWindow(x, y, tkwin); + if (tkwin != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tk_PathName(tkwin),-1)); + } + break; + case WIN_INTERPS: + skip = TkGetDisplayOf(interp, objc - 2, objv + 2, &tkwin); + if (skip < 0) { + return TCL_ERROR; + } + if (objc - skip != 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?-displayof window?"); + return TCL_ERROR; + } + return TkGetInterpNames(interp, tkwin); + case WIN_PATHNAME: { + Window id; + + skip = TkGetDisplayOf(interp, objc - 2, objv + 2, &tkwin); + if (skip < 0) { + return TCL_ERROR; + } + if (objc - skip != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?-displayof window? id"); + return TCL_ERROR; + } + string = Tcl_GetString(objv[2 + skip]); + if (TkpScanWindowId(interp, string, &id) != TCL_OK) { + return TCL_ERROR; + } + winPtr = (TkWindow *) Tk_IdToWindow(Tk_Display(tkwin), id); + if ((winPtr == NULL) || + (winPtr->mainPtr != ((TkWindow *) tkwin)->mainPtr)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "window id \"%s\" doesn't exist in this application", + string)); + Tcl_SetErrorCode(interp, "TK", "LOOKUP", "WINDOW", string, NULL); + return TCL_ERROR; + } + + /* + * If the window is a utility window with no associated path (such as + * a wrapper window or send communication window), just return an + * empty string. + */ + + tkwin = (Tk_Window) winPtr; + if (Tk_PathName(tkwin) != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tk_PathName(tkwin),-1)); + } + break; + } + + /* + * objv[3] is window. + */ + + case WIN_EXISTS: { + int alive; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "window"); + return TCL_ERROR; + } + string = Tcl_GetString(objv[2]); + winPtr = (TkWindow *) Tk_NameToWindow(interp, string, tkwin); + Tcl_ResetResult(interp); + + alive = 1; + if ((winPtr == NULL) || (winPtr->flags & TK_ALREADY_DEAD)) { + alive = 0; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(alive)); + break; + } + case WIN_FPIXELS: { + double mm, pixels; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "window number"); + return TCL_ERROR; + } + if (TkGetWindowFromObj(interp, tkwin, objv[2], &tkwin) != TCL_OK) { + return TCL_ERROR; + } + string = Tcl_GetString(objv[3]); + if (Tk_GetScreenMM(interp, tkwin, string, &mm) != TCL_OK) { + return TCL_ERROR; + } + pixels = mm * WidthOfScreen(Tk_Screen(tkwin)) + / WidthMMOfScreen(Tk_Screen(tkwin)); + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(pixels)); + break; + } + case WIN_PIXELS: { + int pixels; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "window number"); + return TCL_ERROR; + } + if (TkGetWindowFromObj(interp, tkwin, objv[2], &tkwin) != TCL_OK) { + return TCL_ERROR; + } + string = Tcl_GetString(objv[3]); + if (Tk_GetPixels(interp, tkwin, string, &pixels) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(pixels)); + break; + } + case WIN_RGB: { + XColor *colorPtr; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "window colorName"); + return TCL_ERROR; + } + if (TkGetWindowFromObj(interp, tkwin, objv[2], &tkwin) != TCL_OK) { + return TCL_ERROR; + } + colorPtr = Tk_GetColor(interp, tkwin, Tcl_GetString(objv[3])); + if (colorPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf("%d %d %d", + colorPtr->red, colorPtr->green, colorPtr->blue)); + Tk_FreeColor(colorPtr); + break; + } + case WIN_VISUALSAVAILABLE: { + XVisualInfo template, *visInfoPtr; + int count, i; + int includeVisualId; + Tcl_Obj *strPtr, *resultPtr; + char buf[16 + TCL_INTEGER_SPACE]; + char visualIdString[TCL_INTEGER_SPACE]; + + if (objc == 3) { + includeVisualId = 0; + } else if ((objc == 4) + && (strcmp(Tcl_GetString(objv[3]), "includeids") == 0)) { + includeVisualId = 1; + } else { + Tcl_WrongNumArgs(interp, 2, objv, "window ?includeids?"); + return TCL_ERROR; + } + + if (TkGetWindowFromObj(interp, tkwin, objv[2], &tkwin) != TCL_OK) { + return TCL_ERROR; + } + + template.screen = Tk_ScreenNumber(tkwin); + visInfoPtr = XGetVisualInfo(Tk_Display(tkwin), VisualScreenMask, + &template, &count); + if (visInfoPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't find any visuals for screen", -1)); + Tcl_SetErrorCode(interp, "TK", "VISUAL", "NONE", NULL); + return TCL_ERROR; + } + resultPtr = Tcl_NewObj(); + for (i = 0; i < count; i++) { + string = TkFindStateString(visualMap, visInfoPtr[i].class); + if (string == NULL) { + strcpy(buf, "unknown"); + } else { + sprintf(buf, "%s %d", string, visInfoPtr[i].depth); + } + if (includeVisualId) { + sprintf(visualIdString, " 0x%x", + (unsigned) visInfoPtr[i].visualid); + strcat(buf, visualIdString); + } + strPtr = Tcl_NewStringObj(buf, -1); + Tcl_ListObjAppendElement(NULL, resultPtr, strPtr); + } + Tcl_SetObjResult(interp, resultPtr); + XFree((char *) visInfoPtr); + break; + } + } + return TCL_OK; +} + +#if 0 +/* + *---------------------------------------------------------------------- + * + * Tk_WmObjCmd -- + * + * This function is invoked to process the "wm" Tcl command. See the user + * documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tk_WmObjCmd( + ClientData clientData, /* Main window associated with interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tk_Window tkwin; + TkWindow *winPtr; + + static const char *const optionStrings[] = { + "aspect", "client", "command", "deiconify", + "focusmodel", "frame", "geometry", "grid", + "group", "iconbitmap", "iconify", "iconmask", + "iconname", "iconposition", "iconwindow", "maxsize", + "minsize", "overrideredirect", "positionfrom", "protocol", + "resizable", "sizefrom", "state", "title", + "tracing", "transient", "withdraw", NULL + }; + enum options { + TKWM_ASPECT, TKWM_CLIENT, TKWM_COMMAND, TKWM_DEICONIFY, + TKWM_FOCUSMOD, TKWM_FRAME, TKWM_GEOMETRY, TKWM_GRID, + TKWM_GROUP, TKWM_ICONBMP, TKWM_ICONIFY, TKWM_ICONMASK, + TKWM_ICONNAME, TKWM_ICONPOS, TKWM_ICONWIN, TKWM_MAXSIZE, + TKWM_MINSIZE, TKWM_OVERRIDE, TKWM_POSFROM, TKWM_PROTOCOL, + TKWM_RESIZABLE, TKWM_SIZEFROM, TKWM_STATE, TKWM_TITLE, + TKWM_TRACING, TKWM_TRANSIENT, TKWM_WITHDRAW + }; + + tkwin = (Tk_Window) clientData; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option window ?arg?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + if (index == TKWM_TRACING) { + int wmTracing; + TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "tracing ?boolean?"); + return TCL_ERROR; + } + if (objc == 2) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + dispPtr->flags & TK_DISPLAY_WM_TRACING)); + return TCL_OK; + } + if (Tcl_GetBooleanFromObj(interp, objv[2], &wmTracing) != TCL_OK) { + return TCL_ERROR; + } + if (wmTracing) { + dispPtr->flags |= TK_DISPLAY_WM_TRACING; + } else { + dispPtr->flags &= ~TK_DISPLAY_WM_TRACING; + } + return TCL_OK; + } + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "window ?arg?"); + return TCL_ERROR; + } + + winPtr = (TkWindow *) Tk_NameToWindow(interp, + Tcl_GetString(objv[2]), tkwin); + if (winPtr == NULL) { + return TCL_ERROR; + } + if (!(winPtr->flags & TK_TOP_LEVEL)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "window \"%s\" isn't a top-level window", winPtr->pathName)); + Tcl_SetErrorCode(interp, "TK", "LOOKUP", "TOPLEVEL", winPtr->pathName, + NULL); + return TCL_ERROR; + } + + switch ((enum options) index) { + case TKWM_ASPECT: + TkpWmAspectCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_CLIENT: + TkpWmClientCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_COMMAND: + TkpWmCommandCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_DEICONIFY: + TkpWmDeiconifyCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_FOCUSMOD: + TkpWmFocusmodCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_FRAME: + TkpWmFrameCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_GEOMETRY: + TkpWmGeometryCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_GRID: + TkpWmGridCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_GROUP: + TkpWmGroupCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_ICONBMP: + TkpWmIconbitmapCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_ICONIFY: + TkpWmIconifyCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_ICONMASK: + TkpWmIconmaskCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_ICONNAME: + /* + * Slight Unix variation. + */ + TkpWmIconnameCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_ICONPOS: + /* + * nearly same - 1 line more on Unix. + */ + TkpWmIconpositionCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_ICONWIN: + TkpWmIconwindowCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_MAXSIZE: + /* + * Nearly same, win diffs. + */ + TkpWmMaxsizeCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_MINSIZE: + /* + * Nearly same, win diffs + */ + TkpWmMinsizeCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_OVERRIDE: + /* + * Almost same. + */ + TkpWmOverrideCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_POSFROM: + /* + * Equal across platforms + */ + TkpWmPositionfromCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_PROTOCOL: + /* + * Equal across platforms + */ + TkpWmProtocolCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_RESIZABLE: + /* + * Almost same + */ + TkpWmResizableCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_SIZEFROM: + /* + * Equal across platforms + */ + TkpWmSizefromCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_STATE: + TkpWmStateCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_TITLE: + TkpWmTitleCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_TRANSIENT: + TkpWmTransientCmd(interp, tkwin, winPtr, objc, objv); + break; + case TKWM_WITHDRAW: + TkpWmWithdrawCmd(interp, tkwin, winPtr, objc, objv); + break; + } + + updateGeom: + if (!(wmPtr->flags & (WM_UPDATE_PENDING|WM_NEVER_MAPPED))) { + Tcl_DoWhenIdle(UpdateGeometryInfo, winPtr); + wmPtr->flags |= WM_UPDATE_PENDING; + } + return TCL_OK; +} +#endif + +/* + *---------------------------------------------------------------------- + * + * TkGetDisplayOf -- + * + * Parses a "-displayof window" option for various commands. If present, + * the literal "-displayof" should be in objv[0] and the window name in + * objv[1]. + * + * Results: + * The return value is 0 if the argument strings did not contain the + * "-displayof" option. The return value is 2 if the argument strings + * contained both the "-displayof" option and a valid window name. + * Otherwise, the return value is -1 if the window name was missing or + * did not specify a valid window. + * + * If the return value was 2, *tkwinPtr is filled with the token for the + * window specified on the command line. If the return value was -1, an + * error message is left in interp's result object. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkGetDisplayOf( + Tcl_Interp *interp, /* Interpreter for error reporting. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[], /* Argument objects. If it is present, + * "-displayof" should be in objv[0] and + * objv[1] the name of a window. */ + Tk_Window *tkwinPtr) /* On input, contains main window of + * application associated with interp. On + * output, filled with window specified as + * option to "-displayof" argument, or + * unmodified if "-displayof" argument was not + * present. */ +{ + const char *string; + int length; + + if (objc < 1) { + return 0; + } + string = Tcl_GetStringFromObj(objv[0], &length); + if ((length >= 2) && + (strncmp(string, "-displayof", (unsigned) length) == 0)) { + if (objc < 2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "value for \"-displayof\" missing", -1)); + Tcl_SetErrorCode(interp, "TK", "NO_VALUE", "DISPLAYOF", NULL); + return -1; + } + *tkwinPtr = Tk_NameToWindow(interp, Tcl_GetString(objv[1]), *tkwinPtr); + if (*tkwinPtr == NULL) { + return -1; + } + return 2; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TkDeadAppObjCmd -- + * + * If an application has been deleted then all Tk commands will be + * re-bound to this function. + * + * Results: + * A standard Tcl error is reported to let the user know that the + * application is dead. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TkDeadAppObjCmd( + ClientData clientData, /* Dummy. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument strings. */ +{ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't invoke \"%s\" command: application has been destroyed", + Tcl_GetString(objv[0]))); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * GetTopHierarchy -- + * + * Retrieves the top-of-hierarchy window which is the nearest ancestor of + * the specified window. + * + * Results: + * Returns the top-of-hierarchy window, or NULL if the window has no + * ancestor which is at the top of a physical window hierarchy. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static TkWindow * +GetTopHierarchy( + Tk_Window tkwin) /* Window for which the top-of-hierarchy + * ancestor should be deterined. */ +{ + TkWindow *winPtr = (TkWindow *) tkwin; + + while ((winPtr != NULL) && !(winPtr->flags & TK_TOP_HIERARCHY)) { + winPtr = winPtr->parentPtr; + } + return winPtr; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |