int
Tk_Grab(
Tcl_Interp *interp, /* Used for error reporting. */
Tk_Window tkwin, /* Window on whose behalf the pointer is to be
* grabbed. */
int grabGlobal) /* Non-zero means issue a grab to the server
* so that no other application gets mouse or
* keyboard events. Zero means the grab only
* applies within this application. */
{
int grabResult, numTries;
TkWindow *winPtr = (TkWindow *) tkwin;
TkDisplay *dispPtr = winPtr->dispPtr;
TkWindow *winPtr2;
unsigned int serial;
ReleaseButtonGrab(dispPtr);
if (dispPtr->eventualGrabWinPtr != NULL) {
if ((dispPtr->eventualGrabWinPtr == winPtr)
&& (grabGlobal == ((dispPtr->grabFlags & GRAB_GLOBAL) != 0))) {
return TCL_OK;
}
if (dispPtr->eventualGrabWinPtr->mainPtr != winPtr->mainPtr) {
goto alreadyGrabbed;
}
Tk_Ungrab((Tk_Window) dispPtr->eventualGrabWinPtr);
}
Tk_MakeWindowExist(tkwin);
if (!grabGlobal) {
Window dummy1, dummy2;
int dummy3, dummy4, dummy5, dummy6;
unsigned int state;
/*
* Local grab. However, if any mouse buttons are down, turn it into a
* global grab temporarily, until the last button goes up. This does
* two things: (a) it makes sure that we see the button-up event; and
* (b) it allows us to track mouse motion among all of the windows of
* this application.
*/
dispPtr->grabFlags &= ~(GRAB_GLOBAL|GRAB_TEMP_GLOBAL);
XQueryPointer(dispPtr->display, winPtr->window, &dummy1,
&dummy2, &dummy3, &dummy4, &dummy5, &dummy6, &state);
if (state & ALL_BUTTONS) {
dispPtr->grabFlags |= GRAB_TEMP_GLOBAL;
goto setGlobalGrab;
}
} else {
dispPtr->grabFlags |= GRAB_GLOBAL;
setGlobalGrab:
/*
* Tricky point: must ungrab before grabbing. This is needed in case
* there is a button auto-grab already in effect. If there is, and the
* mouse has moved to a different window, X won't generate enter and
* leave events to move the mouse if we grab without ungrabbing.
*/
XUngrabPointer(dispPtr->display, CurrentTime);
serial = NextRequest(dispPtr->display);
/*
* Another tricky point: there are races with some window managers
* that can cause grabs to fail because the window manager hasn't
* released its grab quickly enough. To work around this problem,
* retry a few times after AlreadyGrabbed errors to give the grab
* release enough time to register with the server.
*/
grabResult = 0; /* Needed only to prevent gcc compiler
* warnings. */
for (numTries = 0; numTries < 10; numTries++) {
grabResult = XGrabPointer(dispPtr->display, winPtr->window,
True, ButtonPressMask|ButtonReleaseMask|ButtonMotionMask
|PointerMotionMask, GrabModeAsync, GrabModeAsync, None,
None, CurrentTime);
if (grabResult != AlreadyGrabbed) {
break;
}
Tcl_Sleep(100);
}
if (grabResult != 0) {
goto grabError;
}
grabResult = XGrabKeyboard(dispPtr->display, Tk_WindowId(tkwin),
False, GrabModeAsync, GrabModeAsync, CurrentTime);
if (grabResult != 0) {
XUngrabPointer(dispPtr->display, CurrentTime);
goto grabError;
}
/*
* Eat up any grab-related events generated by the server for the
* grab. There are several reasons for doing this:
*
* 1. We have to synthesize the events for local grabs anyway, since
* the server doesn't participate in them.
* 2. The server doesn't always generate the right events for global
* grabs (e.g. it generates events even if the current window is in
* the grab tree, which we don't want).
* 3. We want all the grab-related events to be processed immediately
* (before other events that are already queued); events coming
* from the server will be in the wrong place, but events we
* synthesize here will go to the front of the queue.
*/
EatGrabEvents(dispPtr, serial);
}
/*
* Synthesize leave events to move the pointer from its current window up
* to the lowest ancestor that it has in common with the grab window.
* However, only do this if the pointer is outside the grab window's
* subtree but inside the grab window's application.
*/
if ((dispPtr->serverWinPtr != NULL)
&& (dispPtr->serverWinPtr->mainPtr == winPtr->mainPtr)) {
for (winPtr2 = dispPtr->serverWinPtr; ; winPtr2 = winPtr2->parentPtr) {
if (winPtr2 == winPtr) {
break;
}
if (winPtr2 == NULL) {
MovePointer2(dispPtr->serverWinPtr, winPtr, NotifyGrab, 1, 0);
break;
}
}
}
QueueGrabWindowChange(dispPtr, winPtr);
return TCL_OK;
grabError:
if (grabResult == GrabNotViewable) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"grab failed: window not viewable", -1));
Tcl_SetErrorCode(interp, "TK", "GRAB", "UNVIEWABLE", NULL);
} else if (grabResult == AlreadyGrabbed) {
alreadyGrabbed:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"grab failed: another application has grab", -1));
Tcl_SetErrorCode(interp, "TK", "GRAB", "GRABBED", NULL);
} else if (grabResult == GrabFrozen) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"grab failed: keyboard or pointer frozen", -1));
Tcl_SetErrorCode(interp, "TK", "GRAB", "FROZEN", NULL);
} else if (grabResult == GrabInvalidTime) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"grab failed: invalid time", -1));
Tcl_SetErrorCode(interp, "TK", "GRAB", "BAD_TIME", NULL);
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"grab failed for unknown reason (code %d)", grabResult));
Tcl_SetErrorCode(interp, "TK", "GRAB", "UNKNOWN", NULL);
}
return TCL_ERROR;
}
void
Tk_OwnSelection(
Tk_Window tkwin, /* Window to become new selection owner. */
Atom selection, /* Selection that window should own. */
Tk_LostSelProc *proc, /* Function to call when selection is taken
* away from tkwin. */
ClientData clientData) /* Arbitrary one-word argument to pass to
* proc. */
{
register TkWindow *winPtr = (TkWindow *) tkwin;
TkDisplay *dispPtr = winPtr->dispPtr;
TkSelectionInfo *infoPtr;
Tk_LostSelProc *clearProc = NULL;
ClientData clearData = NULL;/* Initialization needed only to prevent
* compiler warning. */
if (dispPtr->multipleAtom == None) {
TkSelInit(tkwin);
}
Tk_MakeWindowExist(tkwin);
/*
* This code is somewhat tricky. First, we find the specified selection on
* the selection list. If the previous owner is in this process, and is a
* different window, then we need to invoke the clearProc. However, it's
* dangerous to call the clearProc right now, because it could invoke a
* Tcl script that wrecks the current state (e.g. it could delete the
* window). To be safe, defer the call until the end of the function when
* we no longer care about the state.
*/
for (infoPtr = dispPtr->selectionInfoPtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->selection == selection) {
break;
}
}
if (infoPtr == NULL) {
infoPtr = (TkSelectionInfo*) ckalloc(sizeof(TkSelectionInfo));
infoPtr->selection = selection;
infoPtr->nextPtr = dispPtr->selectionInfoPtr;
dispPtr->selectionInfoPtr = infoPtr;
} else if (infoPtr->clearProc != NULL) {
if (infoPtr->owner != tkwin) {
clearProc = infoPtr->clearProc;
clearData = infoPtr->clearData;
} else if (infoPtr->clearProc == LostSelection) {
/*
* If the selection handler is one created by "selection own", be
* sure to free the record for it; otherwise there will be a
* memory leak.
*/
ckfree((char *) infoPtr->clearData);
}
}
infoPtr->owner = tkwin;
infoPtr->serial = NextRequest(winPtr->display);
infoPtr->clearProc = proc;
infoPtr->clearData = clientData;
/*
* Note that we are using CurrentTime, even though ICCCM recommends
* against this practice (the problem is that we don't necessarily have a
* valid time to use). We will not be able to retrieve a useful timestamp
* for the TIMESTAMP target later.
*/
infoPtr->time = CurrentTime;
/*
* Note that we are not checking to see if the selection claim succeeded.
* If the ownership does not change, then the clearProc may never be
* invoked, and we will return incorrect information when queried for the
* current selection owner.
*/
XSetSelectionOwner(winPtr->display, infoPtr->selection, winPtr->window,
infoPtr->time);
/*
* Now that we are done, we can invoke clearProc without running into
* reentrancy problems.
*/
if (clearProc != NULL) {
(*clearProc)(clearData);
}
}
static int
win_choose_font (ClientData cd, Tcl_Interp *interp, int argc, CONST84 char **argv)
{
CONST84 char *deffont;
Tk_Window parent;
int i, oldMode;
CHOOSEFONTA cf;
LOGFONTA lf;
HDC hdc;
HFONT hfont;
char facebuf[LF_FACESIZE];
TEXTMETRIC tm;
int pointsize;
char *s;
Tcl_DString resultStr; /* used to translate result in UTF8 in Tcl/Tk8.1 */
deffont = NULL;
parent = Tk_MainWindow (interp);
for (i = 1; i < argc; i += 2)
{
if (i + 1 >= argc)
{
Tcl_ResetResult (interp);
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
"value for \"", argv[i], "\" missing",
(char *) NULL);
return TCL_ERROR;
}
if (strcmp (argv[i], "-default") == 0)
deffont = argv[i + 1];
else if (strcmp (argv[i], "-parent") == 0)
{
parent = Tk_NameToWindow (interp, argv[i + 1],
Tk_MainWindow (interp));
if (parent == NULL)
return TCL_ERROR;
}
else
{
Tcl_ResetResult (interp);
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
"unknown option \"", argv[i], "\"",
(char *) NULL);
return TCL_ERROR;
}
}
memset (&cf, 0, sizeof (CHOOSEFONT));
cf.lStructSize = sizeof (CHOOSEFONT);
if (Tk_WindowId (parent) == None)
Tk_MakeWindowExist (parent);
cf.hwndOwner = Tk_GetHWND (Tk_WindowId (parent));
cf.lpLogFont = &lf;
cf.Flags = CF_SCREENFONTS | CF_FORCEFONTEXIST;
memset (&lf, 0, sizeof (LOGFONT));
if (deffont != NULL)
{
Tk_Font tkfont;
const TkFontAttributes *fa;
tkfont = Tk_GetFont (interp, parent, deffont);
if (tkfont == NULL)
return TCL_ERROR;
cf.Flags |= CF_INITTOLOGFONTSTRUCT;
/* In order to initialize LOGFONT, we need to extract the real
font attributes from the Tk internal font information. */
fa = &((TkFont *) tkfont)->fa;
/* This code is taken from TkpGetFontFromAttributes. It
converts a TkFontAttributes structure into a LOGFONT
structure. */
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
lf.lfHeight = - fa->size;
#else
lf.lfHeight = - fa->pointsize;
#endif
if (lf.lfHeight < 0)
lf.lfHeight = MulDiv (lf.lfHeight,
254 * WidthOfScreen (Tk_Screen (parent)),
720 * WidthMMOfScreen (Tk_Screen (parent)));
lf.lfWeight = fa->weight == TK_FW_NORMAL ? FW_NORMAL : FW_BOLD;
lf.lfItalic = fa->slant;
lf.lfUnderline = fa->underline;
lf.lfStrikeOut = fa->overstrike;
lf.lfCharSet = DEFAULT_CHARSET;
lf.lfOutPrecision = OUT_DEFAULT_PRECIS;
lf.lfClipPrecision = CLIP_DEFAULT_PRECIS;
lf.lfQuality = DEFAULT_QUALITY;
lf.lfPitchAndFamily = DEFAULT_PITCH | FF_DONTCARE;
if (fa->family == NULL)
lf.lfFaceName[0] = '\0';
else
strncpy (lf.lfFaceName, fa->family, sizeof (lf.lfFaceName));
Tk_FreeFont (tkfont);
}
oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
if (!ChooseFontA (&cf))
{
DWORD code;
code = CommDlgExtendedError ();
if (code == 0)
{
/* The user pressed cancel. */
Tcl_ResetResult (interp);
return TCL_OK;
}
else
{
char buf[200];
sprintf (buf, "Windows common dialog error 0x%lx", (unsigned long) code);
Tcl_ResetResult (interp);
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, buf, -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr, buf, -1);
#endif
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
Tcl_DStringValue(&resultStr),
(char *) NULL);
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
}
Tcl_SetServiceMode(oldMode);
/* We now have a LOGFONT structure. We store it into a device
context, and then extract enough information to build a Tk font
specification. With luck, when Tk interprets the font
specification it will wind up with the font that the user expects
to see. Some of this code is taken from AllocFont. */
hfont = CreateFontIndirectA (&lf);
if (hfont == NULL)
{
/* This should be impossible. */
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, "CreateFontIndirect failed on chosen font", -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr, "CreateFontIndirect failed on chosen font", -1);
#endif
Tcl_SetResult (interp, Tcl_DStringValue(&resultStr), TCL_STATIC);
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
hdc = GetDC (cf.hwndOwner);
hfont = SelectObject (hdc, hfont);
GetTextFaceA (hdc, sizeof (facebuf), facebuf);
GetTextMetrics (hdc, &tm);
Tcl_ResetResult (interp);
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, facebuf, -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr,facebuf,-1);
#endif
if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1)) != TCL_OK) {
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
Tcl_DStringFree(&resultStr);
pointsize = MulDiv (tm.tmHeight - tm.tmInternalLeading,
720 * WidthMMOfScreen (Tk_Screen (parent)),
254 * WidthOfScreen (Tk_Screen (parent)));
if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
Tcl_NewIntObj (pointsize)) != TCL_OK) {
return TCL_ERROR;
}
if (tm.tmWeight > FW_MEDIUM)
s = "bold";
else
s = "normal";
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, s, -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr, s, -1);
#endif
if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1)) != TCL_OK) {
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
Tcl_DStringFree(&resultStr);
if (tm.tmItalic)
s = "italic";
else
s = "roman";
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, s, -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr, s, -1);
#endif
if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1)) != TCL_OK) {
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
Tcl_DStringFree(&resultStr);
if (tm.tmUnderlined)
{
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, "underline", -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr,"underline",-1);
#endif
if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1))
!= TCL_OK) {
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
Tcl_DStringFree(&resultStr);
}
if (tm.tmStruckOut)
{
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, "overstrike", -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr, "overstrike", -1);
#endif
if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1))
!= TCL_OK) {
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
Tcl_DStringFree(&resultStr);
}
hfont = SelectObject (hdc, hfont);
ReleaseDC (cf.hwndOwner, hdc);
DeleteObject (hfont);
return TCL_OK;
}
static Busy *
CreateBusy(
Tcl_Interp *interp, /* Interpreter to report error to */
Tk_Window tkRef) /* Window hosting the busy window */
{
Busy *busyPtr;
int length, x, y;
const char *fmt;
char *name;
Tk_Window tkBusy, tkChild, tkParent;
Window parent;
Tk_FakeWin *winPtr;
busyPtr = (Busy *) ckalloc(sizeof(Busy));
x = y = 0;
length = strlen(Tk_Name(tkRef));
name = ckalloc(length + 6);
if (Tk_IsTopLevel(tkRef)) {
fmt = "_Busy"; /* Child */
tkParent = tkRef;
} else {
Tk_Window tkwin;
fmt = "%s_Busy"; /* Sibling */
tkParent = Tk_Parent(tkRef);
for (tkwin = tkRef; (tkwin != NULL) && !Tk_IsTopLevel(tkwin);
tkwin = Tk_Parent(tkwin)) {
if (tkwin == tkParent) {
break;
}
x += Tk_X(tkwin) + Tk_Changes(tkwin)->border_width;
y += Tk_Y(tkwin) + Tk_Changes(tkwin)->border_width;
}
}
for (tkChild = FirstChild(tkParent); tkChild != NULL;
tkChild = NextChild(tkChild)) {
Tk_MakeWindowExist(tkChild);
}
sprintf(name, fmt, Tk_Name(tkRef));
tkBusy = Tk_CreateWindow(interp, tkParent, name, NULL);
ckfree(name);
if (tkBusy == NULL) {
return NULL;
}
Tk_MakeWindowExist(tkRef);
busyPtr->display = Tk_Display(tkRef);
busyPtr->interp = interp;
busyPtr->tkRef = tkRef;
busyPtr->tkParent = tkParent;
busyPtr->tkBusy = tkBusy;
busyPtr->width = Tk_Width(tkRef);
busyPtr->height = Tk_Height(tkRef);
busyPtr->x = Tk_X(tkRef);
busyPtr->y = Tk_Y(tkRef);
busyPtr->cursor = None;
Tk_SetClass(tkBusy, "Busy");
busyPtr->optionTable = Tk_CreateOptionTable(interp, busyOptionSpecs);
if (Tk_InitOptions(interp, (char *) busyPtr, busyPtr->optionTable,
tkBusy) != TCL_OK) {
Tk_DestroyWindow(tkBusy);
return NULL;
}
SetWindowInstanceData(tkBusy, busyPtr);
winPtr = (Tk_FakeWin *) tkRef;
TkpCreateBusy(winPtr, tkRef, &parent, tkParent, busyPtr);
MakeTransparentWindowExist(tkBusy, parent);
Tk_MoveResizeWindow(tkBusy, x, y, busyPtr->width, busyPtr->height);
/*
* Only worry if the busy window is destroyed.
*/
Tk_CreateEventHandler(tkBusy, StructureNotifyMask, BusyEventProc,
busyPtr);
/*
* Indicate that the busy window's geometry is being managed. This will
* also notify us if the busy window is ever packed.
*/
Tk_ManageGeometry(tkBusy, &busyMgrInfo, busyPtr);
if (busyPtr->cursor != None) {
Tk_DefineCursor(tkBusy, busyPtr->cursor);
}
/*
* Track the reference window to see if it is resized or destroyed.
*/
Tk_CreateEventHandler(tkRef, StructureNotifyMask, RefWinEventProc,
busyPtr);
return busyPtr;
}
jump_addr gui_call( void )
{
Tcl_Interp *interp;
int rc = 0;
COUNT_ARGS_AT_LEAST(1);
if (EQ(REG0,FALSE_OBJ))
{
COUNT_ARGS(1);
interp = Tcl_CreateInterp();
REG0 = RAW_PTR_TO_OBJ( interp );
}
else if (arg_count_reg > 2 && EQ(REG1,int2fx(4)))
{
obj info;
COUNT_ARGS(3);
interp = (Tcl_Interp *)OBJ_TO_RAW_PTR(REG0);
/* this hook creates a Scheme procedure
for calling the given Tcl command
The arguments to the scheme procedure had
better be strings, fixnums, or symbols.
*/
info = bvec_alloc( sizeof(Tcl_CmdInfo), byte_vector_class );
/*printf( "seeking info on `%s'\n", string_text(REG2) );*/
if (!Tcl_GetCommandInfo( interp,
(char *)string_text(REG2),
(Tcl_CmdInfo *)PTR_TO_DATAPTR(info) ))
{
REG0 = make_string( "command not found" );
REG1 = int2fx(1);
RETURN(1);
}
REG0 = make2(closure_class,
make4(bindingenvt_class,
NIL_OBJ,
info,
RAW_PTR_TO_OBJ(interp),
REG2 ),
make2(template_class,
JUMP_ADDR_TO_OBJ(tcl_gateway),
ZERO));
RETURN1();
}
else
{
COUNT_ARGS(2);
interp = (Tcl_Interp *)OBJ_TO_RAW_PTR(REG0);
if (EQ(REG1,int2fx(0)))
{
switch_hw_regs_back_to_os();
main_tk_win = Tk_CreateMainWindow( interp, NULL, "rs", "RScheme" );
if (!main_tk_win)
{
switch_hw_regs_into_scheme();
goto tcl_error;
}
printf( "main window = %#x\n", main_tk_win );
/*
Tk_GeometryRequest( main_tk_win, 200, 200 );
*/
Tcl_SetVar(interp, "tcl_interactive","0", TCL_GLOBAL_ONLY);
Tcl_CreateCommand(interp,
"scheme-callback",
the_callback,
(ClientData)0,
NULL);
switch_hw_regs_into_scheme();
if ((rc = Tcl_Init(interp)) == TCL_ERROR) {
goto tcl_error;
}
if ((rc = Tk_Init(interp)) == TCL_ERROR) {
goto tcl_error;
}
}
else if (EQ(REG1,int2fx(2)))
{
Tk_MakeWindowExist( main_tk_win );
RETURN0();
}
else if (EQ(REG1,int2fx(1)))
{
evts = NIL_OBJ;
switch_hw_regs_back_to_os();
Tk_DoOneEvent(TK_ALL_EVENTS|TK_DONT_WAIT);
switch_hw_regs_into_scheme();
REG0 = evts;
RETURN(1);
}
else if (EQ(REG1,int2fx(3)))
{
evts = NIL_OBJ;
/* flush events */
switch_hw_regs_back_to_os();
while (Tk_DoOneEvent(TK_ALL_EVENTS|TK_DONT_WAIT));
switch_hw_regs_into_scheme();
REG0 = evts;
RETURN(1);
}
else
{
assert( STRING_P(REG1) );
rc = Tcl_Eval( interp, (char *)string_text(REG1) );
}
REG0 = make_string( interp->result );
}
RETURN(1);
tcl_error:
REG0 = make_string( interp->result );
REG1 = int2fx(rc);
RETURN(2);
}
HGLRC OpenGLGetContext(Tcl_Interp* interp,char* name)
#endif
{
Tcl_CmdInfo info;
OpenGLClientData* OpenGLPtr;
#ifdef _WIN32
HWND hWnd;
#endif
if(!Tcl_GetCommandInfo(interp, name, &info))
return 0;
OpenGLPtr=(OpenGLClientData*)info.clientData;
if (OpenGLPtr->tkwin != Tk_NameToWindow(interp, name, Tk_MainWindow(interp)))
return 0;
if (OpenGLPtr->display != Tk_Display(OpenGLPtr->tkwin))
return 0;
if (OpenGLPtr->display)
XSync(OpenGLPtr->display, False);
if (!OpenGLPtr->x11_win)
{
Tk_MakeWindowExist(OpenGLPtr->tkwin);
XSync(OpenGLPtr->display, False);
OpenGLPtr->x11_win = Tk_WindowId(OpenGLPtr->tkwin);
}
if (!OpenGLPtr->x11_win)
return 0;
#ifndef _WIN32
OpenGLPtr->glx_win = OpenGLPtr->x11_win;
if (!OpenGLPtr->cx)
{
OpenGLPtr->cx = glXCreateContext(OpenGLPtr->display,
OpenGLPtr->vi,
first_context,
OpenGLPtr->direct);
if (!first_context)
{
first_context = OpenGLPtr->cx;
}
}
if (!OpenGLPtr->cx)
{
Tcl_AppendResult(interp, "Error making GL context", (char*)NULL);
return 0;
}
if (!OpenGLPtr->glx_win)
return 0;
#else
hWnd = TkWinGetHWND(Tk_WindowId(OpenGLPtr->tkwin));
OpenGLPtr->hDC = GetDC(hWnd);
if (!OpenGLPtr->cx)
{
OpenGLPtr->cx = wglCreateContext(OpenGLPtr->hDC);
wglShareLists(first_context,OpenGLPtr->cx);
if (!first_context) first_context = OpenGLPtr->cx;
}
if (!OpenGLPtr->cx)
{
Tcl_AppendResult(interp, "Error making GL context", (char*)NULL);
printf("wglCreateContext() returned NULL; Error code: %d\n",
(int)GetLastError());
return 0;
}
#endif
return OpenGLPtr->cx;
}
/* Implement the Windows version of the ide_get_directory command. */
static int
get_directory_command (ClientData cd, Tcl_Interp *interp, int argc,
char **argv)
{
BROWSEINFO bi;
char buf[MAX_PATH + 1];
Tk_Window parent;
int i, oldMode;
LPITEMIDLIST idlist;
char *p;
int atts;
Tcl_DString tempBuffPtr;
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_DString titleDString;
Tcl_DString initialDirDString;
Tcl_DString resultDString;
Tcl_DStringInit(&titleDString);
Tcl_DStringInit(&initialDirDString);
#endif
Tcl_DStringInit(&tempBuffPtr);
bi.hwndOwner = NULL;
bi.pidlRoot = NULL;
bi.pszDisplayName = buf;
bi.lpszTitle = NULL;
bi.ulFlags = 0;
bi.lpfn = NULL;
bi.lParam = 0;
bi.iImage = 0;
parent = Tk_MainWindow (interp);
for (i = 1; i < argc; i += 2)
{
int v;
int len;
v = i + 1;
len = strlen (argv[i]);
if (strncmp (argv[i], "-parent", len) == 0)
{
if (v == argc)
goto arg_missing;
parent = Tk_NameToWindow (interp, argv[v],
Tk_MainWindow (interp));
if (parent == NULL)
return TCL_ERROR;
}
else if (strncmp (argv[i], "-title", len) == 0)
{
if (v == argc)
goto arg_missing;
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_UtfToExternalDString(NULL, argv[v], -1, &titleDString);
bi.lpszTitle = Tcl_DStringValue(&titleDString);
#else
bi.lpszTitle = argv[v];
#endif
}
else if (strncmp (argv[i], "-initialdir", len) == 0)
{
if (v == argc)
goto arg_missing;
/* bi.lParam will be passed to the callback function.(save the need for globals)*/
bi.lParam = (LPARAM) Tcl_TranslateFileName(interp, argv[v], &tempBuffPtr);
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_UtfToExternalDString(NULL, (char *) bi.lParam, -1, &initialDirDString);
bi.lParam = (LPARAM) Tcl_DStringValue(&initialDirDString);
#endif
bi.lpfn = MyBrowseCallbackProc;
}
else
{
Tcl_AppendResult (interp, "unknown option \"", argv[i],
"\", must be -parent or -title", (char *) NULL);
return TCL_ERROR;
}
}
if (Tk_WindowId (parent) == None)
Tk_MakeWindowExist (parent);
bi.hwndOwner = Tk_GetHWND (Tk_WindowId (parent));
oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
idlist = SHBrowseForFolder (&bi);
Tcl_SetServiceMode(oldMode);
if (idlist == NULL)
{
/* User pressed the cancel button. */
return TCL_OK;
}
if (! SHGetPathFromIDList (idlist, buf))
{
Tcl_SetResult (interp, "could not get path for directory", TCL_STATIC);
return TCL_ERROR;
}
/* Ensure the directory exists. */
atts = GetFileAttributesA (buf);
if (atts == -1 || ! (atts & FILE_ATTRIBUTE_DIRECTORY))
{
Tcl_AppendResult (interp, "path \"", buf, "\" is not a directory",
(char *) NULL);
/* FIXME: free IDLIST. */
return TCL_ERROR;
}
/* FIXME: We are supposed to free IDLIST using the shell task
allocator, but cygwin32 doesn't define the required interfaces
yet. */
/* Normalize the path for Tcl. */
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, buf, -1, &resultDString);
p = Tcl_DStringValue(&resultDString);
#else
p = buf;
#endif
for (; *p != '\0'; ++p)
if (*p == '\\')
*p = '/';
Tcl_ResetResult(interp);
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_SetResult(interp, Tcl_DStringValue(&resultDString), TCL_VOLATILE);
Tcl_DStringFree(&resultDString);
Tcl_DStringFree(&titleDString);
Tcl_DStringFree(&initialDirDString);
#else
Tcl_SetResult(interp, buf, TCL_VOLATILE);
#endif
Tcl_DStringFree(&tempBuffPtr);
return TCL_OK;
arg_missing:
Tcl_AppendResult(interp, "value for \"", argv[argc - 1], "\" missing",
NULL);
return TCL_ERROR;
}
