1850 lines
47 KiB
C
1850 lines
47 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-1996 Sun Microsystems, Inc.
|
||
*
|
||
* See the file "license.terms" for information on usage and redistribution
|
||
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||
*
|
||
* SCCS: @(#) tkCmds.c 1.125 97/05/20 16:16:33
|
||
*/
|
||
|
||
#include "tkPort.h"
|
||
#include "tkInt.h"
|
||
#include <errno.h>
|
||
|
||
#ifdef BGLK_CODE
|
||
# define STk_create_tcl_object SCM_CREATE_TCL_OBJECT
|
||
# define STk_get_NIL_value SCM_NIL
|
||
# define STk_get_widget_value tcl_lookup_command
|
||
# define STk_convert_Tcl_string2list SCM_tk_string_to_scm_list
|
||
#endif
|
||
|
||
/*
|
||
* Forward declarations for procedures defined later in this file:
|
||
*/
|
||
|
||
static TkWindow * GetToplevel _ANSI_ARGS_((Tk_Window tkwin));
|
||
static char * WaitVariableProc _ANSI_ARGS_((ClientData clientData,
|
||
Tcl_Interp *interp, char *name1, char *name2,
|
||
int flags));
|
||
static void WaitVisibilityProc _ANSI_ARGS_((ClientData clientData,
|
||
XEvent *eventPtr));
|
||
static void WaitWindowProc _ANSI_ARGS_((ClientData clientData,
|
||
XEvent *eventPtr));
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tk_BellCmd --
|
||
*
|
||
* This procedure 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_BellCmd(clientData, interp, argc, argv)
|
||
ClientData clientData; /* Main window associated with interpreter. */
|
||
Tcl_Interp *interp; /* Current interpreter. */
|
||
int argc; /* Number of arguments. */
|
||
char **argv; /* Argument strings. */
|
||
{
|
||
Tk_Window tkwin = (Tk_Window) clientData;
|
||
size_t length;
|
||
|
||
if ((argc != 1) && (argc != 3)) {
|
||
#ifdef SCM_CODE
|
||
Tcl_AppendResult(interp, "wrong # args: should be (", argv[0],
|
||
" ?:displayof window?)", (char *) NULL);
|
||
#else
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
||
" ?-displayof window?\"", (char *) NULL);
|
||
#endif
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (argc == 3) {
|
||
length = strlen(argv[1]);
|
||
if ((length < 2) || (strncmp(argv[1], "-displayof", length) != 0)) {
|
||
Tcl_AppendResult(interp, "bad option \"", argv[1],
|
||
#ifdef SCM_CODE
|
||
"\": must be :displayof", (char *) NULL);
|
||
#else
|
||
"\": must be -displayof", (char *) NULL);
|
||
#endif
|
||
return TCL_ERROR;
|
||
}
|
||
tkwin = Tk_NameToWindow(interp, argv[2], tkwin);
|
||
if (tkwin == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
XBell(Tk_Display(tkwin), 0);
|
||
XForceScreenSaver(Tk_Display(tkwin), ScreenSaverReset);
|
||
XFlush(Tk_Display(tkwin));
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tk_BindCmd --
|
||
*
|
||
* This procedure 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_BindCmd(clientData, interp, argc, argv)
|
||
ClientData clientData; /* Main window associated with interpreter. */
|
||
Tcl_Interp *interp; /* Current interpreter. */
|
||
int argc; /* Number of arguments. */
|
||
char **argv; /* Argument strings. */
|
||
{
|
||
Tk_Window tkwin = (Tk_Window) clientData;
|
||
TkWindow *winPtr;
|
||
ClientData object;
|
||
|
||
if ((argc < 2) || (argc > 4)) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
||
" window ?pattern? ?command?\"", (char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
if (argv[1][0] == '.') {
|
||
winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[1], tkwin);
|
||
if (winPtr == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
object = (ClientData) winPtr->pathName;
|
||
} else {
|
||
winPtr = (TkWindow *) clientData;
|
||
object = (ClientData) Tk_GetUid(argv[1]);
|
||
}
|
||
|
||
if (argc == 4) {
|
||
#ifndef SCM_CODE
|
||
int append = 0;
|
||
#endif
|
||
unsigned long mask;
|
||
|
||
if (argv[3][0] == 0) {
|
||
return Tk_DeleteBinding(interp, winPtr->mainPtr->bindingTable,
|
||
object, argv[2]);
|
||
}
|
||
#ifndef SCM_CODE
|
||
if (argv[3][0] == '+') {
|
||
argv[3]++;
|
||
append = 1;
|
||
}
|
||
#endif
|
||
#ifndef SCM_CODE
|
||
mask = Tk_CreateBinding(interp, winPtr->mainPtr->bindingTable,
|
||
object, argv[2], argv[3], append);
|
||
#else
|
||
mask = Tk_CreateBinding(interp, winPtr->mainPtr->bindingTable,
|
||
object, argv[2], argv[3], argv[1], "");
|
||
#endif
|
||
if (mask == 0) {
|
||
return TCL_ERROR;
|
||
}
|
||
} else if (argc == 3) {
|
||
char *command;
|
||
|
||
command = Tk_GetBinding(interp, winPtr->mainPtr->bindingTable,
|
||
object, argv[2]);
|
||
if (command == NULL) {
|
||
Tcl_ResetResult(interp);
|
||
return TCL_OK;
|
||
}
|
||
|
||
#ifdef SCM_CODE
|
||
if (*command == '(') {
|
||
char *p = interp->result;
|
||
|
||
/* Result is short (something like #pXXXX) => it fits in interp->result */
|
||
for (command++; *command && *command!=' ' && *command!=')'; command++)
|
||
*p++ = *command;
|
||
}
|
||
else
|
||
#endif
|
||
interp->result = command;
|
||
} else {
|
||
Tk_GetAllBindings(interp, winPtr->mainPtr->bindingTable, object);
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TkBindEventProc --
|
||
*
|
||
* This procedure 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(winPtr, eventPtr)
|
||
TkWindow *winPtr; /* Pointer to info about window. */
|
||
XEvent *eventPtr; /* Information about event. */
|
||
{
|
||
#define MAX_OBJS 20
|
||
ClientData objects[MAX_OBJS], *objPtr;
|
||
static Tk_Uid allUid = NULL;
|
||
TkWindow *topLevPtr;
|
||
int i, count;
|
||
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 = (ClientData *) ckalloc((unsigned)
|
||
(winPtr->numTags * sizeof(ClientData)));
|
||
}
|
||
for (i = 0; i < winPtr->numTags; i++) {
|
||
p = (char *) 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_LEVEL);
|
||
topLevPtr = topLevPtr->parentPtr) {
|
||
/* Empty loop body. */
|
||
}
|
||
if ((winPtr != topLevPtr) && (topLevPtr != NULL)) {
|
||
count = 4;
|
||
objPtr[2] = (ClientData) topLevPtr->pathName;
|
||
} else {
|
||
count = 3;
|
||
}
|
||
if (allUid == NULL) {
|
||
allUid = Tk_GetUid("all");
|
||
}
|
||
objPtr[count-1] = (ClientData) allUid;
|
||
}
|
||
Tk_BindEvent(winPtr->mainPtr->bindingTable, eventPtr, (Tk_Window) winPtr,
|
||
count, objPtr);
|
||
if (objPtr != objects) {
|
||
ckfree((char *) objPtr);
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tk_BindtagsCmd --
|
||
*
|
||
* This procedure 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_BindtagsCmd(clientData, interp, argc, argv)
|
||
ClientData clientData; /* Main window associated with interpreter. */
|
||
Tcl_Interp *interp; /* Current interpreter. */
|
||
int argc; /* Number of arguments. */
|
||
char **argv; /* Argument strings. */
|
||
{
|
||
Tk_Window tkwin = (Tk_Window) clientData;
|
||
TkWindow *winPtr, *winPtr2;
|
||
int i, tagArgc;
|
||
char *p, **tagArgv;
|
||
|
||
if ((argc < 2) || (argc > 3)) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
||
" window ?tags?\"", (char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[1], tkwin);
|
||
if (winPtr == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
if (argc == 2) {
|
||
#ifdef SCM_CODE
|
||
Tcl_AppendResult(interp, "(", NULL);
|
||
#endif
|
||
if (winPtr->numTags == 0) {
|
||
#ifdef STk_CODE
|
||
Tcl_AppendResult(interp, " #.", winPtr->pathName, NULL);
|
||
Tcl_AppendResult(interp, " \"", winPtr->classUid, "\"", NULL);
|
||
#else
|
||
# ifdef BGLK_CODE
|
||
Tcl_AppendResult(interp, " \"", winPtr->pathName, "\"", NULL);
|
||
Tcl_AppendResult(interp, " \"", winPtr->classUid, "\"", NULL);
|
||
# else
|
||
Tcl_AppendElement(interp, winPtr->pathName);
|
||
Tcl_AppendElement(interp, winPtr->classUid);
|
||
# endif
|
||
#endif
|
||
for (winPtr2 = winPtr;
|
||
(winPtr2 != NULL) && !(winPtr2->flags & TK_TOP_LEVEL);
|
||
winPtr2 = winPtr2->parentPtr) {
|
||
/* Empty loop body. */
|
||
}
|
||
if ((winPtr != winPtr2) && (winPtr2 != NULL)) {
|
||
#ifdef STk_CODE
|
||
Tcl_AppendResult(interp, " #.", winPtr2->pathName, NULL);
|
||
#else
|
||
# ifdef BGLK_CODE
|
||
Tcl_AppendResult(interp, " \"", winPtr2->pathName, "\"", NULL);
|
||
# else
|
||
Tcl_AppendElement(interp, winPtr2->pathName);
|
||
# endif
|
||
#endif
|
||
}
|
||
#ifdef SCM_CODE
|
||
Tcl_AppendElement(interp, "\"all\"");
|
||
#else
|
||
Tcl_AppendElement(interp, "all");
|
||
#endif
|
||
} else {
|
||
for (i = 0; i < winPtr->numTags; i++) {
|
||
#ifdef STk_CODE
|
||
char *s = (char *) winPtr->tagPtr[i];
|
||
|
||
if (*s == '.')
|
||
Tcl_AppendResult(interp, " #.", s, NULL);
|
||
else
|
||
Tcl_AppendResult(interp, " \"", s, "\"", NULL);
|
||
#else
|
||
# ifdef BGLK_CODE
|
||
Tcl_AppendResult(interp, " \"", (char *) winPtr->tagPtr[i],
|
||
"\"", NULL);
|
||
# else
|
||
Tcl_AppendElement(interp, (char *) winPtr->tagPtr[i]);
|
||
# endif
|
||
#endif
|
||
}
|
||
}
|
||
#ifdef SCM_CODE
|
||
Tcl_AppendResult(interp, ")", NULL);
|
||
#endif
|
||
return TCL_OK;
|
||
}
|
||
if (winPtr->tagPtr != NULL) {
|
||
TkFreeBindingTags(winPtr);
|
||
}
|
||
if (argv[2][0] == 0) {
|
||
return TCL_OK;
|
||
}
|
||
if (Tcl_SplitList(interp, argv[2], &tagArgc, &tagArgv) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
winPtr->numTags = tagArgc;
|
||
winPtr->tagPtr = (ClientData *) ckalloc((unsigned)
|
||
(tagArgc * sizeof(ClientData)));
|
||
for (i = 0; i < tagArgc; i++) {
|
||
p = tagArgv[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.
|
||
*/
|
||
|
||
#ifdef BGLK_CODE
|
||
copy = (char *) ckalloc_atomic((unsigned) (strlen(p) + 1));
|
||
#else
|
||
copy = (char *) ckalloc((unsigned) (strlen(p) + 1));
|
||
#endif
|
||
strcpy(copy, p);
|
||
winPtr->tagPtr[i] = (ClientData) copy;
|
||
} else {
|
||
winPtr->tagPtr[i] = (ClientData) Tk_GetUid(p);
|
||
}
|
||
}
|
||
ckfree((char *) tagArgv);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TkFreeBindingTags --
|
||
*
|
||
* This procedure 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(winPtr)
|
||
TkWindow *winPtr; /* Window whose tags are to be released. */
|
||
{
|
||
int i;
|
||
char *p;
|
||
|
||
for (i = 0; i < winPtr->numTags; i++) {
|
||
p = (char *) (winPtr->tagPtr[i]);
|
||
if (*p == '.') {
|
||
/*
|
||
* Names starting with "." are malloced rather than Uids, so
|
||
* they have to be freed.
|
||
*/
|
||
|
||
ckfree(p);
|
||
}
|
||
}
|
||
ckfree((char *) winPtr->tagPtr);
|
||
winPtr->numTags = 0;
|
||
winPtr->tagPtr = NULL;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tk_DestroyCmd --
|
||
*
|
||
* This procedure 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_DestroyCmd(clientData, interp, argc, argv)
|
||
ClientData clientData; /* Main window associated with
|
||
* interpreter. */
|
||
Tcl_Interp *interp; /* Current interpreter. */
|
||
int argc; /* Number of arguments. */
|
||
char **argv; /* Argument strings. */
|
||
{
|
||
Tk_Window window;
|
||
Tk_Window tkwin = (Tk_Window) clientData;
|
||
int i;
|
||
|
||
for (i = 1; i < argc; i++) {
|
||
window = Tk_NameToWindow(interp, argv[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_LowerCmd --
|
||
*
|
||
* This procedure 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_LowerCmd(clientData, interp, argc, argv)
|
||
ClientData clientData; /* Main window associated with
|
||
* interpreter. */
|
||
Tcl_Interp *interp; /* Current interpreter. */
|
||
int argc; /* Number of arguments. */
|
||
char **argv; /* Argument strings. */
|
||
{
|
||
Tk_Window mainwin = (Tk_Window) clientData;
|
||
Tk_Window tkwin, other;
|
||
|
||
if ((argc != 2) && (argc != 3)) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " window ?belowThis?\"", (char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
tkwin = Tk_NameToWindow(interp, argv[1], mainwin);
|
||
if (tkwin == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
if (argc == 2) {
|
||
other = NULL;
|
||
} else {
|
||
other = Tk_NameToWindow(interp, argv[2], mainwin);
|
||
if (other == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
if (Tk_RestackWindow(tkwin, Below, other) != TCL_OK) {
|
||
Tcl_AppendResult(interp, "can't lower \"", argv[1], "\" below \"",
|
||
argv[2], "\"", (char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tk_RaiseCmd --
|
||
*
|
||
* This procedure 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_RaiseCmd(clientData, interp, argc, argv)
|
||
ClientData clientData; /* Main window associated with
|
||
* interpreter. */
|
||
Tcl_Interp *interp; /* Current interpreter. */
|
||
int argc; /* Number of arguments. */
|
||
char **argv; /* Argument strings. */
|
||
{
|
||
Tk_Window mainwin = (Tk_Window) clientData;
|
||
Tk_Window tkwin, other;
|
||
|
||
if ((argc != 2) && (argc != 3)) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " window ?aboveThis?\"", (char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
tkwin = Tk_NameToWindow(interp, argv[1], mainwin);
|
||
if (tkwin == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
if (argc == 2) {
|
||
other = NULL;
|
||
} else {
|
||
other = Tk_NameToWindow(interp, argv[2], mainwin);
|
||
if (other == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
if (Tk_RestackWindow(tkwin, Above, other) != TCL_OK) {
|
||
Tcl_AppendResult(interp, "can't raise \"", argv[1], "\" above \"",
|
||
argv[2], "\"", (char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tk_TkObjCmd --
|
||
*
|
||
* This procedure is invoked to process the "tk" 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_TkObjCmd(clientData, interp, objc, objv)
|
||
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;
|
||
Tk_Window tkwin;
|
||
static char *optionStrings[] = {
|
||
"appname", "scaling", NULL
|
||
};
|
||
enum options {
|
||
TK_APPNAME, TK_SCALING
|
||
};
|
||
|
||
tkwin = (Tk_Window) clientData;
|
||
|
||
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;
|
||
}
|
||
|
||
switch ((enum options) index) {
|
||
case TK_APPNAME: {
|
||
TkWindow *winPtr;
|
||
char *string;
|
||
|
||
winPtr = (TkWindow *) tkwin;
|
||
|
||
if (objc > 3) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, "?newName?");
|
||
return TCL_ERROR;
|
||
}
|
||
if (objc == 3) {
|
||
string = Tcl_GetStringFromObj(objv[2], NULL);
|
||
winPtr->nameUid = Tk_GetUid(Tk_SetAppName(tkwin, string));
|
||
}
|
||
Tcl_SetStringObj(Tcl_GetObjResult(interp), winPtr->nameUid, -1);
|
||
break;
|
||
}
|
||
case TK_SCALING: {
|
||
Screen *screenPtr;
|
||
int skip, width, height;
|
||
double d;
|
||
|
||
screenPtr = Tk_Screen(tkwin);
|
||
|
||
skip = TkGetDisplayOf(interp, objc - 2, objv + 2, &tkwin);
|
||
if (skip < 0) {
|
||
return TCL_ERROR;
|
||
}
|
||
if (objc - skip == 2) {
|
||
d = 25.4 / 72;
|
||
d *= WidthOfScreen(screenPtr);
|
||
d /= WidthMMOfScreen(screenPtr);
|
||
Tcl_SetDoubleObj(Tcl_GetObjResult(interp), d);
|
||
} else if (objc - skip == 3) {
|
||
if (Tcl_GetDoubleFromObj(interp, objv[2 + 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, 2, objv,
|
||
#ifdef SCM_CODE
|
||
"?:displayof window? ?factor?");
|
||
#else
|
||
"?-displayof window? ?factor?");
|
||
#endif
|
||
return TCL_ERROR;
|
||
}
|
||
break;
|
||
}
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tk_TkwaitCmd --
|
||
*
|
||
* This procedure 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_TkwaitCmd(clientData, interp, argc, argv)
|
||
ClientData clientData; /* Main window associated with
|
||
* interpreter. */
|
||
Tcl_Interp *interp; /* Current interpreter. */
|
||
int argc; /* Number of arguments. */
|
||
char **argv; /* Argument strings. */
|
||
{
|
||
Tk_Window tkwin = (Tk_Window) clientData;
|
||
int c, done;
|
||
size_t length;
|
||
|
||
if (argc != 3) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " variable|visibility|window name\"", (char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
c = argv[1][0];
|
||
length = strlen(argv[1]);
|
||
if ((c == 'v') && (strncmp(argv[1], "variable", length) == 0)
|
||
&& (length >= 2)) {
|
||
if (Tcl_TraceVar(interp, argv[2],
|
||
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
|
||
WaitVariableProc, (ClientData) &done) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
done = 0;
|
||
while (!done) {
|
||
Tcl_DoOneEvent(0);
|
||
}
|
||
Tcl_UntraceVar(interp, argv[2],
|
||
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
|
||
WaitVariableProc, (ClientData) &done);
|
||
} else if ((c == 'v') && (strncmp(argv[1], "visibility", length) == 0)
|
||
&& (length >= 2)) {
|
||
Tk_Window window;
|
||
|
||
window = Tk_NameToWindow(interp, argv[2], tkwin);
|
||
if (window == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
Tk_CreateEventHandler(window, VisibilityChangeMask|StructureNotifyMask,
|
||
WaitVisibilityProc, (ClientData) &done);
|
||
done = 0;
|
||
while (!done) {
|
||
Tcl_DoOneEvent(0);
|
||
}
|
||
if (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_AppendResult(interp, "window \"", argv[2],
|
||
"\" was deleted before its visibility changed",
|
||
(char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
Tk_DeleteEventHandler(window, VisibilityChangeMask|StructureNotifyMask,
|
||
WaitVisibilityProc, (ClientData) &done);
|
||
} else if ((c == 'w') && (strncmp(argv[1], "window", length) == 0)) {
|
||
Tk_Window window;
|
||
|
||
window = Tk_NameToWindow(interp, argv[2], tkwin);
|
||
if (window == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
Tk_CreateEventHandler(window, StructureNotifyMask,
|
||
WaitWindowProc, (ClientData) &done);
|
||
done = 0;
|
||
while (!done) {
|
||
Tcl_DoOneEvent(0);
|
||
}
|
||
/*
|
||
* Note: there's no need to delete the event handler. It was
|
||
* deleted automatically when the window was destroyed.
|
||
*/
|
||
} else {
|
||
Tcl_AppendResult(interp, "bad option \"", argv[1],
|
||
"\": must be variable, visibility, or window", (char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Clear out the interpreter's result, since it may have been set
|
||
* by event handlers.
|
||
*/
|
||
|
||
Tcl_ResetResult(interp);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/* ARGSUSED */
|
||
static char *
|
||
WaitVariableProc(clientData, interp, name1, name2, flags)
|
||
ClientData clientData; /* Pointer to integer to set to 1. */
|
||
Tcl_Interp *interp; /* Interpreter containing variable. */
|
||
char *name1; /* Name of variable. */
|
||
char *name2; /* Second part of variable name. */
|
||
int flags; /* Information about what happened. */
|
||
{
|
||
int *donePtr = (int *) clientData;
|
||
|
||
*donePtr = 1;
|
||
return (char *) NULL;
|
||
}
|
||
|
||
/*ARGSUSED*/
|
||
static void
|
||
WaitVisibilityProc(clientData, eventPtr)
|
||
ClientData clientData; /* Pointer to integer to set to 1. */
|
||
XEvent *eventPtr; /* Information about event (not used). */
|
||
{
|
||
int *donePtr = (int *) clientData;
|
||
|
||
if (eventPtr->type == VisibilityNotify) {
|
||
*donePtr = 1;
|
||
}
|
||
if (eventPtr->type == DestroyNotify) {
|
||
*donePtr = 2;
|
||
}
|
||
}
|
||
|
||
static void
|
||
WaitWindowProc(clientData, eventPtr)
|
||
ClientData clientData; /* Pointer to integer to set to 1. */
|
||
XEvent *eventPtr; /* Information about event. */
|
||
{
|
||
int *donePtr = (int *) clientData;
|
||
|
||
if (eventPtr->type == DestroyNotify) {
|
||
*donePtr = 1;
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tk_UpdateCmd --
|
||
*
|
||
* This procedure 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_UpdateCmd(clientData, interp, argc, argv)
|
||
ClientData clientData; /* Main window associated with
|
||
* interpreter. */
|
||
Tcl_Interp *interp; /* Current interpreter. */
|
||
int argc; /* Number of arguments. */
|
||
char **argv; /* Argument strings. */
|
||
{
|
||
int flags;
|
||
TkDisplay *dispPtr;
|
||
|
||
if (argc == 1) {
|
||
flags = TCL_DONT_WAIT;
|
||
} else if (argc == 2) {
|
||
if (strncmp(argv[1], "idletasks", strlen(argv[1])) != 0) {
|
||
Tcl_AppendResult(interp, "bad option \"", argv[1],
|
||
"\": must be idletasks", (char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
flags = TCL_IDLE_EVENTS;
|
||
} else {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " ?idletasks?\"", (char *) NULL);
|
||
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) {
|
||
/* Empty loop body */
|
||
}
|
||
for (dispPtr = tkDisplayList; dispPtr != NULL;
|
||
dispPtr = dispPtr->nextPtr) {
|
||
XSync(dispPtr->display, False);
|
||
}
|
||
if (Tcl_DoOneEvent(flags) == 0) {
|
||
break;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Must clear the interpreter's result because event handlers could
|
||
* have executed commands.
|
||
*/
|
||
|
||
Tcl_ResetResult(interp);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* Tk_WinfoObjCmd --
|
||
*
|
||
* This procedure 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, interp, objc, objv)
|
||
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;
|
||
char buf[128];
|
||
char *string;
|
||
TkWindow *winPtr;
|
||
Tk_Window tkwin;
|
||
|
||
static TkStateMap visualMap[] = {
|
||
{PseudoColor, "pseudocolor"},
|
||
{GrayScale, "grayscale"},
|
||
{DirectColor, "directcolor"},
|
||
{TrueColor, "truecolor"},
|
||
{StaticColor, "staticcolor"},
|
||
{StaticGray, "staticgray"},
|
||
{-1, NULL}
|
||
};
|
||
static char *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
|
||
};
|
||
|
||
tkwin = (Tk_Window) clientData;
|
||
|
||
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_GetStringFromObj(objv[2], NULL);
|
||
tkwin = Tk_NameToWindow(interp, string, tkwin);
|
||
if (tkwin == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
winPtr = (TkWindow *) tkwin;
|
||
|
||
switch ((enum options) index) {
|
||
case WIN_CELLS: {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp),
|
||
Tk_Visual(tkwin)->map_entries);
|
||
break;
|
||
}
|
||
case WIN_CHILDREN: {
|
||
Tcl_Obj *strPtr;
|
||
|
||
#ifdef SCM_CODE
|
||
Tcl_SetObjResult(interp, STk_create_tcl_object(STk_get_NIL_value()));
|
||
winPtr = winPtr->childList;
|
||
for ( ; winPtr != NULL; winPtr = winPtr->nextPtr) {
|
||
strPtr=STk_create_tcl_object(STk_get_widget_value(winPtr->pathName));
|
||
Tcl_ListObjAppendElement(NULL,
|
||
Tcl_GetObjResult(interp), strPtr);
|
||
}
|
||
#else
|
||
Tcl_ResetResult(interp);
|
||
winPtr = winPtr->childList;
|
||
for ( ; winPtr != NULL; winPtr = winPtr->nextPtr) {
|
||
strPtr = Tcl_NewStringObj(winPtr->pathName, -1);
|
||
Tcl_ListObjAppendElement(NULL,
|
||
Tcl_GetObjResult(interp), strPtr);
|
||
}
|
||
#endif
|
||
break;
|
||
}
|
||
case WIN_CLASS: {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetStringObj(Tcl_GetObjResult(interp), Tk_Class(tkwin), -1);
|
||
break;
|
||
}
|
||
case WIN_COLORMAPFULL: {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetBooleanObj(Tcl_GetObjResult(interp),
|
||
TkpCmapStressed(tkwin, Tk_Colormap(tkwin)));
|
||
break;
|
||
}
|
||
case WIN_DEPTH: {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_Depth(tkwin));
|
||
break;
|
||
}
|
||
case WIN_GEOMETRY: {
|
||
Tcl_ResetResult(interp);
|
||
sprintf(buf, "%dx%d+%d+%d", Tk_Width(tkwin), Tk_Height(tkwin),
|
||
Tk_X(tkwin), Tk_Y(tkwin));
|
||
Tcl_SetStringObj(Tcl_GetObjResult(interp), buf, -1);
|
||
break;
|
||
}
|
||
case WIN_HEIGHT: {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_Height(tkwin));
|
||
break;
|
||
}
|
||
case WIN_ID: {
|
||
Tk_MakeWindowExist(tkwin);
|
||
TkpPrintWindowId(buf, Tk_WindowId(tkwin));
|
||
Tcl_ResetResult(interp);
|
||
#ifdef SCM_CODE
|
||
{
|
||
long res;
|
||
sscanf(buf, "%lx", &res);
|
||
Tcl_SetLongObj(Tcl_GetObjResult(interp), res);
|
||
}
|
||
#else
|
||
Tcl_SetStringObj(Tcl_GetObjResult(interp), buf, -1);
|
||
#endif
|
||
break;
|
||
}
|
||
case WIN_ISMAPPED: {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetBooleanObj(Tcl_GetObjResult(interp),
|
||
(int) Tk_IsMapped(tkwin));
|
||
break;
|
||
}
|
||
case WIN_MANAGER: {
|
||
Tcl_ResetResult(interp);
|
||
if (winPtr->geomMgrPtr != NULL) {
|
||
Tcl_SetStringObj(Tcl_GetObjResult(interp),
|
||
winPtr->geomMgrPtr->name, -1);
|
||
}
|
||
#ifdef SCM_CODE
|
||
else
|
||
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 0);
|
||
#endif
|
||
break;
|
||
}
|
||
case WIN_NAME: {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetStringObj(Tcl_GetObjResult(interp), Tk_Name(tkwin), -1);
|
||
break;
|
||
}
|
||
case WIN_PARENT: {
|
||
Tcl_ResetResult(interp);
|
||
if (winPtr->parentPtr != NULL) {
|
||
#ifdef SCM_CODE
|
||
Tcl_SetObjResult(interp,
|
||
STk_create_tcl_object(
|
||
STk_get_widget_value(
|
||
winPtr->parentPtr->pathName)));
|
||
#else
|
||
Tcl_SetStringObj(Tcl_GetObjResult(interp),
|
||
winPtr->parentPtr->pathName, -1);
|
||
#endif
|
||
}
|
||
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 = GetToplevel(tkwin);
|
||
if (winPtr == NULL) {
|
||
x = -1;
|
||
y = -1;
|
||
} else {
|
||
TkGetPointerCoords((Tk_Window) winPtr, &x, &y);
|
||
}
|
||
Tcl_ResetResult(interp);
|
||
if (useX & useY) {
|
||
sprintf(buf, "%d %d", x, y);
|
||
#ifdef SCM_CODE
|
||
Tcl_SetObjResult(interp,
|
||
STk_create_tcl_object(
|
||
STk_convert_Tcl_string2list(buf)));
|
||
#else
|
||
Tcl_SetStringObj(Tcl_GetObjResult(interp), buf, -1);
|
||
#endif
|
||
} else if (useX) {
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp), x);
|
||
} else {
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp), y);
|
||
}
|
||
break;
|
||
}
|
||
case WIN_REQHEIGHT: {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_ReqHeight(tkwin));
|
||
break;
|
||
}
|
||
case WIN_REQWIDTH: {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_ReqWidth(tkwin));
|
||
break;
|
||
}
|
||
case WIN_ROOTX: {
|
||
Tk_GetRootCoords(tkwin, &x, &y);
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp), x);
|
||
break;
|
||
}
|
||
case WIN_ROOTY: {
|
||
Tk_GetRootCoords(tkwin, &x, &y);
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp), y);
|
||
break;
|
||
}
|
||
case WIN_SCREEN: {
|
||
sprintf(buf, "%d", Tk_ScreenNumber(tkwin));
|
||
Tcl_ResetResult(interp);
|
||
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
||
Tk_DisplayName(tkwin), ".", buf, NULL);
|
||
break;
|
||
}
|
||
case WIN_SCREENCELLS: {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp),
|
||
CellsOfScreen(Tk_Screen(tkwin)));
|
||
break;
|
||
}
|
||
case WIN_SCREENDEPTH: {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp),
|
||
DefaultDepthOfScreen(Tk_Screen(tkwin)));
|
||
break;
|
||
}
|
||
case WIN_SCREENHEIGHT: {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp),
|
||
HeightOfScreen(Tk_Screen(tkwin)));
|
||
break;
|
||
}
|
||
case WIN_SCREENWIDTH: {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp),
|
||
WidthOfScreen(Tk_Screen(tkwin)));
|
||
break;
|
||
}
|
||
case WIN_SCREENMMHEIGHT: {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp),
|
||
HeightMMOfScreen(Tk_Screen(tkwin)));
|
||
break;
|
||
}
|
||
case WIN_SCREENMMWIDTH: {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp),
|
||
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 = GetToplevel(tkwin);
|
||
if (winPtr != NULL) {
|
||
#ifdef SCM_CODE
|
||
Tcl_SetObjResult(interp,
|
||
STk_create_tcl_object(
|
||
STk_get_widget_value(winPtr->pathName)));
|
||
#else
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetStringObj(Tcl_GetObjResult(interp),
|
||
winPtr->pathName, -1);
|
||
#endif
|
||
}
|
||
break;
|
||
}
|
||
case WIN_VIEWABLE: {
|
||
int viewable;
|
||
|
||
viewable = 0;
|
||
for ( ; ; winPtr = winPtr->parentPtr) {
|
||
if ((winPtr == NULL) || !(winPtr->flags & TK_MAPPED)) {
|
||
break;
|
||
}
|
||
if (winPtr->flags & TK_TOP_LEVEL) {
|
||
viewable = 1;
|
||
break;
|
||
}
|
||
}
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), viewable);
|
||
break;
|
||
}
|
||
case WIN_VISUAL: {
|
||
class = Tk_Visual(tkwin)->class;
|
||
|
||
visual:
|
||
string = TkFindStateString(visualMap, class);
|
||
if (string == NULL) {
|
||
string = "unknown";
|
||
}
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetStringObj(Tcl_GetObjResult(interp), string, -1);
|
||
break;
|
||
}
|
||
case WIN_VISUALID: {
|
||
#ifdef SCM_CODE
|
||
Tcl_SetLongObj(Tcl_GetObjResult(interp),
|
||
(long) XVisualIDFromVisual(Tk_Visual(tkwin)));
|
||
#else
|
||
Tcl_ResetResult(interp);
|
||
sprintf(buf, "0x%x",
|
||
(unsigned int) XVisualIDFromVisual(Tk_Visual(tkwin)));
|
||
Tcl_SetStringObj(Tcl_GetObjResult(interp), buf, -1);
|
||
#endif
|
||
break;
|
||
}
|
||
case WIN_VROOTHEIGHT: {
|
||
Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height);
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp), height);
|
||
break;
|
||
}
|
||
case WIN_VROOTWIDTH: {
|
||
Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height);
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp), width);
|
||
break;
|
||
}
|
||
case WIN_VROOTX: {
|
||
Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height);
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp), x);
|
||
break;
|
||
}
|
||
case WIN_VROOTY: {
|
||
Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height);
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp), y);
|
||
break;
|
||
}
|
||
case WIN_WIDTH: {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_Width(tkwin));
|
||
break;
|
||
}
|
||
case WIN_X: {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_X(tkwin));
|
||
break;
|
||
}
|
||
case WIN_Y: {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp), 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) {
|
||
#ifdef SCM_CODE
|
||
Tcl_WrongNumArgs(interp, 2, objv, "?:displayof window? name");
|
||
#else
|
||
Tcl_WrongNumArgs(interp, 2, objv, "?-displayof window? name");
|
||
#endif
|
||
return TCL_ERROR;
|
||
}
|
||
objv += skip;
|
||
string = Tcl_GetStringFromObj(objv[2], NULL);
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetLongObj(Tcl_GetObjResult(interp),
|
||
(long) Tk_InternAtom(tkwin, string));
|
||
break;
|
||
}
|
||
case WIN_ATOMNAME: {
|
||
char *name;
|
||
long id;
|
||
|
||
skip = TkGetDisplayOf(interp, objc - 2, objv + 2, &tkwin);
|
||
if (skip < 0) {
|
||
return TCL_ERROR;
|
||
}
|
||
if (objc - skip != 3) {
|
||
#ifdef SCM_CODE
|
||
Tcl_WrongNumArgs(interp, 2, objv, "?:displayof window? id");
|
||
#else
|
||
Tcl_WrongNumArgs(interp, 2, objv, "?-displayof window? id");
|
||
#endif
|
||
return TCL_ERROR;
|
||
}
|
||
objv += skip;
|
||
if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
Tcl_ResetResult(interp);
|
||
name = Tk_GetAtomName(tkwin, (Atom) id);
|
||
if (strcmp(name, "?bad atom?") == 0) {
|
||
string = Tcl_GetStringFromObj(objv[2], NULL);
|
||
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
||
"no atom exists with id \"", string, "\"", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
Tcl_SetStringObj(Tcl_GetObjResult(interp), 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,
|
||
#ifdef SCM_CODE
|
||
"?:displayof window? rootX rootY");
|
||
#else
|
||
"?-displayof window? rootX rootY");
|
||
#endif
|
||
return TCL_ERROR;
|
||
}
|
||
objv += skip;
|
||
string = Tcl_GetStringFromObj(objv[2], NULL);
|
||
if (Tk_GetPixels(interp, tkwin, string, &x) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
string = Tcl_GetStringFromObj(objv[3], NULL);
|
||
if (Tk_GetPixels(interp, tkwin, string, &y) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
tkwin = Tk_CoordsToWindow(x, y, tkwin);
|
||
if (tkwin != NULL) {
|
||
#ifdef SCM_CODE
|
||
Tcl_SetObjResult(interp,
|
||
STk_create_tcl_object(
|
||
STk_get_widget_value(Tk_PathName(tkwin))));
|
||
#else
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetStringObj(Tcl_GetObjResult(interp),
|
||
Tk_PathName(tkwin), -1);
|
||
#endif
|
||
}
|
||
#ifdef SCM_CODE
|
||
else {
|
||
/* No window; return #f */
|
||
Tcl_SetBooleanObj(Tcl_GetObjResult(interp),0);
|
||
}
|
||
#endif
|
||
break;
|
||
}
|
||
case WIN_INTERPS: {
|
||
int result;
|
||
|
||
skip = TkGetDisplayOf(interp, objc - 2, objv + 2, &tkwin);
|
||
if (skip < 0) {
|
||
return TCL_ERROR;
|
||
}
|
||
if (objc - skip != 2) {
|
||
#ifdef SCM_CODE
|
||
Tcl_WrongNumArgs(interp, 2, objv, "?:displayof window?");
|
||
#else
|
||
Tcl_WrongNumArgs(interp, 2, objv, "?-displayof window?");
|
||
#endif
|
||
return TCL_ERROR;
|
||
}
|
||
result = TkGetInterpNames(interp, tkwin);
|
||
#ifdef SCM_CODE
|
||
if (result == TCL_OK) {
|
||
Tcl_SetObjResult(interp,
|
||
STk_create_tcl_object(
|
||
STk_convert_Tcl_string2list(interp->result)));
|
||
}
|
||
#endif
|
||
return result;
|
||
}
|
||
case WIN_PATHNAME: {
|
||
int id;
|
||
|
||
skip = TkGetDisplayOf(interp, objc - 2, objv + 2, &tkwin);
|
||
if (skip < 0) {
|
||
return TCL_ERROR;
|
||
}
|
||
if (objc - skip != 3) {
|
||
#ifdef SCM_CODE
|
||
Tcl_WrongNumArgs(interp, 2, objv, "?:displayof window? id");
|
||
#else
|
||
Tcl_WrongNumArgs(interp, 2, objv, "?-displayof window? id");
|
||
#endif
|
||
return TCL_ERROR;
|
||
}
|
||
string = Tcl_GetStringFromObj(objv[2 + skip], NULL);
|
||
if (TkpScanWindowId(interp, string, &id) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
winPtr = (TkWindow *)
|
||
Tk_IdToWindow(Tk_Display(tkwin), (Window) id);
|
||
if ((winPtr == NULL) ||
|
||
(winPtr->mainPtr != ((TkWindow *) tkwin)->mainPtr)) {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
||
"window id \"", string,
|
||
"\" doesn't exist in this application", (char *) 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) {
|
||
#ifdef SCM_CODE
|
||
Tcl_SetObjResult(interp,
|
||
STk_create_tcl_object(
|
||
STk_get_widget_value(Tk_PathName(tkwin))));
|
||
#else
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetStringObj(Tcl_GetObjResult(interp),
|
||
Tk_PathName(tkwin), -1);
|
||
#endif
|
||
}
|
||
break;
|
||
}
|
||
|
||
/*
|
||
* objv[3] is window.
|
||
*/
|
||
|
||
case WIN_EXISTS: {
|
||
int alive;
|
||
|
||
if (objc != 3) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, "window");
|
||
return TCL_ERROR;
|
||
}
|
||
string = Tcl_GetStringFromObj(objv[2], NULL);
|
||
winPtr = (TkWindow *) Tk_NameToWindow(interp, string, tkwin);
|
||
alive = 1;
|
||
if ((winPtr == NULL) || (winPtr->flags & TK_ALREADY_DEAD)) {
|
||
alive = 0;
|
||
}
|
||
Tcl_ResetResult(interp); /* clear any error msg */
|
||
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), alive);
|
||
break;
|
||
}
|
||
case WIN_FPIXELS: {
|
||
double mm, pixels;
|
||
|
||
if (objc != 4) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, "window number");
|
||
return TCL_ERROR;
|
||
}
|
||
string = Tcl_GetStringFromObj(objv[2], NULL);
|
||
tkwin = Tk_NameToWindow(interp, string, tkwin);
|
||
if (tkwin == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
string = Tcl_GetStringFromObj(objv[3], NULL);
|
||
if (Tk_GetScreenMM(interp, tkwin, string, &mm) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
pixels = mm * WidthOfScreen(Tk_Screen(tkwin))
|
||
/ WidthMMOfScreen(Tk_Screen(tkwin));
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetDoubleObj(Tcl_GetObjResult(interp), pixels);
|
||
break;
|
||
}
|
||
case WIN_PIXELS: {
|
||
int pixels;
|
||
|
||
if (objc != 4) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, "window number");
|
||
return TCL_ERROR;
|
||
}
|
||
string = Tcl_GetStringFromObj(objv[2], NULL);
|
||
tkwin = Tk_NameToWindow(interp, string, tkwin);
|
||
if (tkwin == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
string = Tcl_GetStringFromObj(objv[3], NULL);
|
||
if (Tk_GetPixels(interp, tkwin, string, &pixels) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetIntObj(Tcl_GetObjResult(interp), pixels);
|
||
break;
|
||
}
|
||
case WIN_RGB: {
|
||
XColor *colorPtr;
|
||
|
||
if (objc != 4) {
|
||
Tcl_WrongNumArgs(interp, 2, objv, "window colorName");
|
||
return TCL_ERROR;
|
||
}
|
||
string = Tcl_GetStringFromObj(objv[2], NULL);
|
||
tkwin = Tk_NameToWindow(interp, string, tkwin);
|
||
if (tkwin == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
string = Tcl_GetStringFromObj(objv[3], NULL);
|
||
colorPtr = Tk_GetColor(interp, tkwin, string);
|
||
if (colorPtr == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
sprintf(buf, "%d %d %d", colorPtr->red, colorPtr->green,
|
||
colorPtr->blue);
|
||
Tk_FreeColor(colorPtr);
|
||
#ifdef SCM_CODE
|
||
Tcl_SetObjResult(interp,
|
||
STk_create_tcl_object(
|
||
STk_convert_Tcl_string2list(buf)));
|
||
#else
|
||
Tcl_ResetResult(interp);
|
||
Tcl_SetStringObj(Tcl_GetObjResult(interp), buf, -1);
|
||
#endif
|
||
break;
|
||
}
|
||
case WIN_VISUALSAVAILABLE: {
|
||
XVisualInfo template, *visInfoPtr;
|
||
int count, i;
|
||
char visualIdString[16];
|
||
int includeVisualId;
|
||
#ifndef SCM_CODE
|
||
Tcl_Obj *strPtr;
|
||
#endif
|
||
|
||
if (objc == 3) {
|
||
includeVisualId = 0;
|
||
} else if ((objc == 4)
|
||
&& (strcmp(Tcl_GetStringFromObj(objv[3], NULL),
|
||
"includeids") == 0)) {
|
||
includeVisualId = 1;
|
||
} else {
|
||
#ifdef SCM_CODE
|
||
Tcl_WrongNumArgs(interp, 2, objv, "window ?'includeids?");
|
||
#else
|
||
Tcl_WrongNumArgs(interp, 2, objv, "window ?includeids?");
|
||
#endif
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
string = Tcl_GetStringFromObj(objv[2], NULL);
|
||
tkwin = Tk_NameToWindow(interp, string, tkwin);
|
||
if (tkwin == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
template.screen = Tk_ScreenNumber(tkwin);
|
||
visInfoPtr = XGetVisualInfo(Tk_Display(tkwin), VisualScreenMask,
|
||
&template, &count);
|
||
Tcl_ResetResult(interp);
|
||
if (visInfoPtr == NULL) {
|
||
Tcl_SetStringObj(Tcl_GetObjResult(interp),
|
||
"can't find any visuals for screen", -1);
|
||
return TCL_ERROR;
|
||
}
|
||
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) {
|
||
#ifdef SCM_CODE
|
||
sprintf(visualIdString, " %d",
|
||
#else
|
||
sprintf(visualIdString, " 0x%x",
|
||
#endif
|
||
(unsigned int) visInfoPtr[i].visualid);
|
||
strcat(buf, visualIdString);
|
||
}
|
||
#ifdef SCM_CODE
|
||
Tcl_ListObjAppendElement(interp,
|
||
Tcl_GetObjResult(interp),
|
||
(Tcl_Obj *) STk_convert_Tcl_string2list(buf));
|
||
#else
|
||
strPtr = Tcl_NewStringObj(buf, -1);
|
||
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
|
||
strPtr);
|
||
#endif
|
||
}
|
||
XFree((char *) visInfoPtr);
|
||
break;
|
||
}
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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(interp, objc, objv, tkwinPtr)
|
||
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. */
|
||
{
|
||
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_SetStringObj(Tcl_GetObjResult(interp),
|
||
#ifdef SCM_CODE
|
||
"value for \":displayof\" missing", -1);
|
||
#else
|
||
"value for \"-displayof\" missing", -1);
|
||
#endif
|
||
return -1;
|
||
}
|
||
string = Tcl_GetStringFromObj(objv[1], NULL);
|
||
*tkwinPtr = Tk_NameToWindow(interp, string, *tkwinPtr);
|
||
if (*tkwinPtr == NULL) {
|
||
return -1;
|
||
}
|
||
return 2;
|
||
}
|
||
return 0;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TkDeadAppCmd --
|
||
*
|
||
* If an application has been deleted then all Tk commands will be
|
||
* re-bound to this procedure.
|
||
*
|
||
* 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
|
||
TkDeadAppCmd(clientData, interp, argc, argv)
|
||
ClientData clientData; /* Dummy. */
|
||
Tcl_Interp *interp; /* Current interpreter. */
|
||
int argc; /* Number of arguments. */
|
||
char **argv; /* Argument strings. */
|
||
{
|
||
Tcl_AppendResult(interp, "can't invoke \"", argv[0],
|
||
"\" command: application has been destroyed", (char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* GetToplevel --
|
||
*
|
||
* Retrieves the toplevel window which is the nearest ancestor of
|
||
* of the specified window.
|
||
*
|
||
* Results:
|
||
* Returns the toplevel window or NULL if the window has no
|
||
* ancestor which is a toplevel.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static TkWindow *
|
||
GetToplevel(tkwin)
|
||
Tk_Window tkwin; /* Window for which the toplevel should be
|
||
* deterined. */
|
||
{
|
||
TkWindow *winPtr = (TkWindow *) tkwin;
|
||
|
||
while (!(winPtr->flags & TK_TOP_LEVEL)) {
|
||
winPtr = winPtr->parentPtr;
|
||
if (winPtr == NULL) {
|
||
return NULL;
|
||
}
|
||
}
|
||
return winPtr;
|
||
}
|