2164 lines
56 KiB
C
2164 lines
56 KiB
C
/*
|
||
* 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:
|
||
*/
|