Back to index

plt-scheme  4.2.1
mredx.cxx
Go to the documentation of this file.
00001 /*
00002  * File:        mredx.cc
00003  * Purpose:     MrEd X Windows event loop
00004  * Author:      Matthew Flatt
00005  * Created:     1996
00006  * Copyright:   (c) 2004-2009 PLT Scheme Inc.
00007  * Copyright:   (c) 1996, Matthew Flatt
00008  */
00009 
00010 #define Uses_XtIntrinsic
00011 #define Uses_XtIntrinsicP
00012 #define Uses_XLib
00013 
00014 #include "wx_main.h"
00015 #include "wx_win.h"
00016 #include "wx_clipb.h"
00017 #include "scheme.h"
00018 
00019 #include "mred.h"
00020 
00021 #include <X11/Shell.h>
00022 
00023 static int short_circuit = 0, just_check = 0, checking_for_break = 0;
00024 static Widget just_this_one;
00025 
00026 static Widget orig_top_level;
00027 static Widget save_top_level = 0;
00028 
00029 static KeyCode breaking_code;
00030 static int breaking_code_set = 0;
00031 
00032 static Widget *grab_stack, grabber;
00033 static int grab_stack_pos = 0, grab_stack_size = 0;
00034 #define WSTACK_INC 3
00035 
00036 extern Widget wx_clipWindow, wx_selWindow;
00037 
00038 Window wxAddClipboardWindowProperty(Atom prop);
00039 extern Atom wx_single_instance_tag;
00040 
00041 wxWindow *wxLocationToWindow(int x, int y);
00042 
00043 extern "C" {
00044   void wxAddGrab(Widget w)
00045     {
00046       if (!grab_stack_pos) {
00047        Widget *naya;
00048        if (!grab_stack)
00049          wxREGGLOB(grab_stack);
00050        grab_stack_size += WSTACK_INC;
00051        naya = (Widget *)scheme_malloc(grab_stack_size * sizeof(Widget));
00052        memcpy(naya + WSTACK_INC, grab_stack, (grab_stack_size - WSTACK_INC) * sizeof(Widget));
00053        grab_stack = naya;
00054        grab_stack_pos = WSTACK_INC;
00055       }
00056 
00057       grabber = grab_stack[--grab_stack_pos] = w;
00058     }
00059 
00060   void wxRemoveGrab(Widget w)
00061     {
00062       if (w != grabber)
00063        return;
00064 
00065       if (++grab_stack_pos < grab_stack_size)
00066        grabber = grab_stack[grab_stack_pos];
00067       else
00068        grabber = NULL;
00069     }
00070 };
00071 
00072 Widget wxGetAppToplevel()
00073 {
00074   if (save_top_level)
00075     return save_top_level;
00076   else {
00077     MrEdContext *c;
00078     c = MrEdGetContext();
00079     return c->finalized->toplevel;
00080   }
00081 }
00082 
00083 void wxPutAppToplevel(Widget w)
00084 {
00085   save_top_level = w;
00086 }
00087 
00088 void MrEdInitFirstContext(MrEdContext *c)
00089 {
00090   orig_top_level = save_top_level;
00091   c->finalized->toplevel = save_top_level;
00092   save_top_level = 0;
00093 }
00094 
00095 void MrEdInitNewContext(MrEdContext *c)
00096 {
00097   wxInitNewToplevel();
00098   c->finalized->toplevel = save_top_level;
00099   save_top_level = 0;
00100 }
00101 
00102 void MrEdDestroyContext(MrEdFinalizedContext *c)
00103 {
00104   XtDestroyWidget(c->toplevel);
00105 }
00106 
00107 static Window GetEventWindow(XEvent *e)
00108 {
00109   Window window = 0;
00110 
00111 #define WINCASEEX(type, record, field) case type: window = e->record.field; break
00112 #define WINCASE(type, record) WINCASEEX(type, record, window)
00113 
00114   switch (e->type) {
00115     WINCASE(KeyPress, xkey);
00116     WINCASE(KeyRelease, xkey);
00117     WINCASE(ButtonPress, xbutton);
00118     WINCASE(ButtonRelease, xbutton);
00119     WINCASE(MotionNotify, xmotion);
00120     WINCASE(EnterNotify, xcrossing);
00121     WINCASE(LeaveNotify, xcrossing);
00122     WINCASE(FocusIn, xfocus);
00123     WINCASE(FocusOut, xfocus);
00124     WINCASE(KeymapNotify, xkeymap);
00125     WINCASE(Expose, xexpose);
00126     WINCASEEX(GraphicsExpose, xgraphicsexpose, drawable);
00127     WINCASEEX(NoExpose, xnoexpose, drawable);
00128     WINCASE(VisibilityNotify, xvisibility);
00129     WINCASE(CreateNotify, xcreatewindow);
00130     WINCASE(DestroyNotify, xdestroywindow);
00131     WINCASE(UnmapNotify, xunmap);
00132     WINCASE(MapNotify, xmap);
00133     WINCASE(MapRequest, xmaprequest);
00134     WINCASE(ReparentNotify, xreparent);
00135     WINCASE(ConfigureNotify, xconfigure);
00136     WINCASE(ConfigureRequest, xconfigurerequest);
00137     WINCASE(GravityNotify, xgravity);
00138     WINCASE(ResizeRequest, xresizerequest);
00139     WINCASE(CirculateNotify, xcirculate);
00140     WINCASE(CirculateRequest, xcirculaterequest);
00141     WINCASE(PropertyNotify, xproperty);
00142     WINCASE(SelectionClear, xselectionclear);
00143     WINCASEEX(SelectionRequest, xselectionrequest, owner);
00144     WINCASEEX(SelectionNotify, xselection, requestor);
00145     WINCASE(ColormapNotify, xcolormap);
00146     WINCASE(ClientMessage, xclient);
00147     WINCASE(MappingNotify, xmapping);
00148   default:
00149     break;
00150   }
00151 
00152   return window;
00153 }
00154 
00155 static unsigned long lastUngrabTime;
00156 static unsigned long lastUnhideTime;
00157 static int need_unhide = 0;
00158 
00159 class Check_Ungrab_Record {
00160 public:
00161   Window window;
00162   int x, y, x_root, y_root;
00163   Check_Ungrab_Record *next;
00164 };
00165 
00166 static int cur_registered = 0;
00167 static Check_Ungrab_Record *first_cur = NULL, *last_cur = NULL;
00168 
00169 static void CheckUngrab(Display *dpy, Check_Ungrab_Record *cur)
00170 {     
00171   Window root;
00172   int x, y;
00173   unsigned w, h, b, d;
00174   
00175   XGetGeometry(dpy, cur->window, 
00176               &root, &x, &y, &w, &h,
00177               &b, &d);
00178   if ((cur->x < 0) || (cur->y < 0)
00179       || ((unsigned int)cur->x > w) || ((unsigned int)cur->y > h)) {
00180     /* Looks bad, but is it a click in a MrEd window
00181        that we could care about? */
00182     
00183     wxWindow *w;
00184     w = wxLocationToWindow(cur->x_root, cur->y_root);
00185     
00186     if (w) {
00187       /* Looks like we need to ungrab */
00188       XUngrabPointer(dpy, 0);
00189       XUngrabKeyboard(dpy, 0);
00190     }
00191   }
00192 }
00193 
00194 static Bool CheckPred(Display *display, XEvent *e, char *args)
00195 {
00196   Window window;
00197   Widget widget;
00198 
00199   switch (e->type) {
00200   case ButtonPress:
00201   case ButtonRelease:
00202   case MotionNotify:
00203     if (e->xbutton.time > lastUnhideTime) {
00204       lastUnhideTime = e->xbutton.time;
00205       need_unhide = 1;
00206     }
00207     break;
00208   default:
00209     break;
00210   }
00211 
00212   if (short_circuit)
00213     return FALSE;
00214 
00215 #if 0
00216   printf("trying %s\n", get_event_type(e));
00217 #endif
00218 
00219   window = GetEventWindow(e);
00220 
00221   if (window) {
00222     widget = XtWindowToWidget(display, window);
00223 #if 1
00224     if (widget)
00225       if (e->type == DestroyNotify)
00226        printf("DestroyNotified window %lx is still widget-mapped; BadWindow error is imminent.\n", window);
00227 #endif
00228   } else
00229     widget = 0;
00230 
00231   /* Check for mouse-down events outside the indicated window.  That
00232      might indicate a mouse grab gone awry, and we need to fix it.
00233      The only legitimate grabs that operate on other windows are with
00234      menus, and those have no wx counterpart. */
00235   if (widget && (e->type == ButtonPress)) {
00236     /* lastUngrabTime keeps us from checking the same events
00237        over and over again. */
00238     if (e->xbutton.time > lastUngrabTime) {
00239       Check_Ungrab_Record *cur;
00240       if (!cur_registered) {
00241        wxREGGLOB(first_cur);
00242        wxREGGLOB(last_cur);
00243       }
00244       cur = new WXGC_PTRS Check_Ungrab_Record;
00245       cur->window = e->xbutton.window;
00246       cur->x = e->xbutton.x;
00247       cur->y = e->xbutton.y;
00248       cur->x_root = e->xbutton.x_root;
00249       cur->y_root = e->xbutton.y_root;
00250       if (last_cur)
00251        last_cur->next = cur;
00252       else
00253        first_cur = cur;
00254       last_cur = cur;
00255       lastUngrabTime = e->xbutton.time;
00256     }
00257   }
00258 
00259   if (widget) {
00260     Widget parent = 0;
00261 
00262     /* Special hack in cooperation with Clipboard.cc
00263        to make clipboard operations happen in the right
00264        eventspace. */
00265     if (widget == wx_clipWindow) {
00266       wxClipboardClient *clipOwner;
00267       clipOwner = wxTheClipboard->GetClipboardClient();
00268       if (clipOwner) {
00269        MrEdContext *cc = (MrEdContext *)clipOwner->context;
00270        if (cc)
00271          parent = cc->finalized->toplevel;
00272       }
00273     }
00274     if (widget == wx_selWindow) {
00275       wxClipboardClient *clipOwner;
00276       clipOwner = wxTheSelection->GetClipboardClient();
00277       if (clipOwner) {
00278        MrEdContext *cc = (MrEdContext *)clipOwner->context;
00279        if (cc)
00280          parent = cc->finalized->toplevel;
00281       }
00282     }
00283 
00284     if (!parent) {
00285       for (parent = widget; XtParent(parent); parent = XtParent(parent)) {
00286       }
00287     }
00288     
00289 #if 0
00290     printf("parent: %lx context: %lx\n", parent, parent_context);
00291 #endif
00292 
00293     if (just_this_one) {
00294       if (parent == just_this_one) {
00295        if (checking_for_break) {
00296          if (e->type == KeyPress) {
00297            if ((e->xkey.state & ControlMask) 
00298 #if BREAKING_REQUIRES_SHIFT
00299               && (e->xkey.state & ShiftMask)
00300 #endif
00301               && (e->xkey.keycode == breaking_code))
00302              goto found;
00303          }
00304        } else {
00305          goto found;
00306        }
00307       } else {
00308 #if 0
00309        printf("wrong eventspace (%lx != %lx)\n", just_this_one, parent_context);
00310 #endif
00311       }
00312     } else {
00313       MrEdContext *c;
00314       
00315       for (c = mred_contexts; c; c = c->next) {
00316        if (c->finalized->toplevel == parent) {
00317          if (!c->ready) {
00318 #if 0
00319            printf("not ready\n");
00320 #endif
00321            return FALSE;
00322          } else {
00323            if (args)
00324              *(MrEdContext **)args = c;
00325            goto found;
00326          }
00327        }
00328       }
00329 
00330       /* Toplevel without context; handle in the main context: */
00331 #if 0
00332       printf("Can't map top-level to eventspace for %lx\n", window);
00333 #endif
00334       if (checking_for_break)
00335        return FALSE;
00336       else {
00337        if (args)
00338          *(MrEdContext **)args = NULL;
00339        goto found;
00340       }
00341     }
00342 
00343   } else {
00344 #if 0
00345     printf("warning: window->widget mapping failed: %lx; event: %d; parent: %lx\n", 
00346           window, e->type, ((XCreateWindowEvent *)e)->parent);
00347 #endif
00348     if (checking_for_break)
00349       return FALSE;
00350     else if (just_this_one)
00351       return FALSE;
00352     else {
00353       /* Toplevel without context; handle in the main context: */
00354       if (args)
00355        *(MrEdContext **)args = NULL;
00356       goto found;
00357     }
00358   }
00359 
00360   return FALSE;
00361 
00362  found:
00363   if (just_check) {
00364     short_circuit = TRUE;
00365     return FALSE;
00366   } else
00367     return TRUE;
00368 }
00369 
00370 
00371 int MrEdGetNextEvent(int check_only, int current_only, 
00372                    XEvent *event, MrEdContext **which)
00373 {
00374   Display *d;
00375   int got;
00376 
00377   if (which)
00378     *which = NULL;
00379 
00380   just_check = check_only;
00381   just_this_one = (current_only ? wxGetAppToplevel() : (Widget)NULL);
00382 
00383   if (!orig_top_level)
00384     d = XtDisplay(save_top_level);
00385   else
00386     d = XtDisplay(orig_top_level);
00387 
00388   got = XCheckIfEvent(d, event, CheckPred, (char *)which);
00389 
00390   if (need_unhide) {
00391     need_unhide = 0;
00392     wxUnhideAllCursors();
00393   }
00394 
00395   while (first_cur) {
00396     CheckUngrab(d, first_cur);
00397     first_cur = first_cur->next;
00398   }
00399   last_cur = NULL;
00400 
00401   if (got) {
00402     just_check = 0;
00403     return 1;
00404   } else if (short_circuit) {
00405     short_circuit = 0;
00406     return 1;
00407   }
00408 
00409   return 0;
00410 }
00411 
00412 static Scheme_Hash_Table *disabled_widgets;
00413 
00414 #ifdef MZ_PRECISE_GC
00415 static void widget_hash_indices(void *_key, long *_h, long *_h2)
00416 {
00417   long lkey;
00418   long h, h2;
00419   
00420   lkey = (long)_key;
00421 
00422   h = (lkey >> 2);
00423   h2 = (lkey >> 3);
00424 
00425   if (_h)
00426     *_h = h;
00427   if (_h2)
00428     *_h2 = h2;
00429 }
00430 #endif
00431 
00432 void wxSetSensitive(Widget w, Bool enabled)
00433 {
00434   if (!disabled_widgets) {
00435     if (enabled)
00436       return;
00437 
00438     wxREGGLOB(disabled_widgets);
00439     disabled_widgets = scheme_make_hash_table(SCHEME_hash_ptr);
00440 #ifdef MZ_PRECISE_GC
00441     disabled_widgets->make_hash_indices = widget_hash_indices;
00442 #endif
00443   }
00444 
00445   if (enabled) {
00446     scheme_hash_set(disabled_widgets, (Scheme_Object *)w, NULL);
00447   } else {
00448     scheme_hash_set(disabled_widgets, (Scheme_Object *)w, (Scheme_Object *)0x1);
00449   }
00450 }
00451 
00452 #ifdef MZ_PRECISE_GC
00453 START_XFORM_SKIP;
00454 #endif
00455 /* No GC here because it's used to draw GC bitmaps */
00456 
00457 Display *MrEdGetXDisplay(void)
00458 {
00459   if (!orig_top_level)
00460     return XtDisplay(save_top_level);
00461   else
00462     return XtDisplay(orig_top_level);
00463 }
00464 
00465 int MrEdGetDoubleTime(void)
00466 {
00467   return XtGetMultiClickTime(MrEdGetXDisplay());
00468 }
00469 
00470 #ifdef MZ_PRECISE_GC
00471 END_XFORM_SKIP;
00472 #endif
00473 
00474 void MrEdDispatchEvent(XEvent *event)
00475 {
00476   if (disabled_widgets) {
00477     int type = event->type;
00478     Display *d;
00479     
00480     d = MrEdGetXDisplay();
00481 
00482     if ((type == KeyPress)
00483        || (type == KeyRelease)
00484        || (type == ButtonPress)
00485        || (type == ButtonRelease)
00486        || (type == MotionNotify)
00487        || (type == EnterNotify)
00488        || (type == LeaveNotify)
00489        || ((type == ClientMessage)
00490            && !strcmp(XGetAtomName(d, event->xclient.message_type), "WM_PROTOCOLS")
00491            && !strcmp(XGetAtomName(d, event->xclient.data.l[0]), "WM_DELETE_WINDOW"))) {
00492       Window window;
00493       Widget widget, ow, exempt = 0;
00494       MrEdContext *c;
00495       wxWindow *ew;
00496 
00497       window = GetEventWindow(event);
00498 
00499       if (window)
00500        widget = XtWindowToWidget(d, window);
00501       else
00502        widget = 0;
00503       ow = widget;
00504 
00505       c = MrEdGetContext();
00506       ew = c->modal_window;
00507       if (ew) {
00508        wxWindow_Xintern *ph;
00509        ph = ew->GetHandle();
00510        exempt = ph->frame;
00511       }
00512 
00513       while (widget) {
00514        if (widget == grabber)
00515          break;
00516 
00517        /* Only start checking the enabled state with the first
00518           top-level window. That way, PreOnChar and PreOnEvent are
00519            called appropriately. wxWindows/Xt ensures that key and mouse
00520            events are not dispatched to disabled items. */
00521 
00522        if (XtIsSubclass(widget, transientShellWidgetClass)
00523            || XtIsSubclass(widget, topLevelShellWidgetClass)) {
00524          
00525          if (scheme_hash_get(disabled_widgets, (Scheme_Object *)widget)) {
00526 #if 0
00527            printf("disabled: %lx from %lx\n", widget, ow);
00528 #endif
00529            return;
00530          }
00531        }
00532 
00533        if (widget == exempt)
00534          break;
00535 
00536        widget = XtParent(widget);
00537       }
00538     }
00539   }
00540 
00541   XtDispatchEvent(event);
00542 }
00543 
00544 int MrEdCheckForBreak(void)
00545 {
00546   int br;
00547   GC_CAN_IGNORE XEvent e;
00548   Display *d;
00549 
00550   if (!orig_top_level)
00551     d = XtDisplay(save_top_level);
00552   else
00553     d = XtDisplay(orig_top_level);
00554 
00555   if (!breaking_code_set) {
00556     breaking_code = XKeysymToKeycode(d, 'c');
00557     breaking_code_set = 1;
00558   }
00559 
00560   XFlush(d);
00561 
00562   checking_for_break = 1;
00563   br = MrEdGetNextEvent(0, 1, &e, NULL);
00564   checking_for_break = 0;
00565 
00566   return br;
00567 }
00568 
00569 #include "wx_timer.h"
00570 
00571 class wxXtTimer : public wxTimer
00572 {
00573 public:
00574   XtTimerCallbackProc callback;
00575   XtPointer data;
00576   int ok;
00577   Widget wgt;
00578 
00579   wxXtTimer(Widget w, XtTimerCallbackProc c, XtPointer d);
00580 
00581   Bool Start(int millisec = -1, Bool one_shot = FALSE);
00582 
00583   void Stopped() { ok = 0; }
00584 
00585   void Notify(void);
00586 };
00587 
00588 wxXtTimer::wxXtTimer(Widget w, XtTimerCallbackProc c, XtPointer d)
00589 : wxTimer()
00590 {
00591   callback = c;
00592   wgt = w;
00593   data = d;
00594   ok = 1;
00595 }
00596 
00597 void wxXtTimer::Notify(void) {
00598   /* Used to try to avoid starving other events, but yielding 
00599      has its own problems. In particular, it messes up dialogs
00600      that expect show #f to immediately lead to a return from
00601      show #t. */
00602   // wxYield();
00603 
00604   if (ok)
00605     callback(data, NULL);
00606 }
00607 
00608 Bool wxXtTimer::Start(int millisec, Bool one_shot)
00609 {
00610   Widget parent;
00611 
00612   /* Only start the timer if the context is consistnt with
00613      the original widget, the context is still running,
00614      etc. */
00615   for (parent = wgt; XtParent(parent); parent = XtParent(parent)) {
00616   }
00617 
00618   if (context
00619       && !((MrEdContext *)context)->killed
00620       && ((MrEdContext *)context)->finalized
00621       && (((MrEdContext *)context)->finalized->toplevel == parent)) {
00622     return wxTimer::Start(millisec, one_shot);
00623   }
00624   return FALSE;
00625 }
00626 
00627 extern "C" {
00628 
00629   void wxRemoveTimeOut(long timer)
00630     {
00631       wxXtTimer *t;
00632 #ifdef MZ_PRECISE_GC
00633       t = *(wxXtTimer **)timer;
00634       GC_free_immobile_box((void **)timer);
00635 #else
00636       t = (wxXtTimer *)timer;
00637 #endif
00638 
00639       t->Stop();
00640       t->Stopped();
00641 
00642 #ifdef MZ_PRECISE_GC
00643       XFORM_RESET_VAR_STACK;
00644 #endif
00645     }
00646   
00647   long wxAppAddTimeOut(XtAppContext app_ctx, unsigned long interval, 
00648                      XtTimerCallbackProc callback, XtPointer data,
00649                      Widget w)
00650     {
00651       wxTimer *t;
00652       long result;
00653 
00654       t = new wxXtTimer(w, callback, data);
00655       t->Start(interval, TRUE);
00656 #ifdef MZ_PRECISE_GC
00657       result = (long)GC_malloc_immobile_box(t);
00658 #else
00659       result = (long)t;
00660 #endif
00661 
00662 #ifdef MZ_PRECISE_GC
00663       XFORM_RESET_VAR_STACK;
00664 #endif
00665 
00666       return result;
00667     }
00668 }
00669 
00670 /***********************************************************************/
00671 
00672 typedef struct {
00673   Widget w;
00674   wxWindow *wx;
00675 } FindRec;
00676 
00677 void *IsWidgetFrame(wxObject *f, void *d)
00678 {
00679   FindRec *fr = (FindRec *)d;
00680   wxWindow_Xintern *i;
00681   
00682   i = ((wxWindow *)f)->GetHandle();
00683   if (i->frame == fr->w) {
00684     fr->wx = (wxWindow *)f;
00685   }
00686 
00687   return d;
00688 }
00689 
00690 static wxWindow *FindMrEdWindow(Display *d, Window xw)
00691 {
00692   Widget w;
00693   w = XtWindowToWidget(d, xw);
00694   if (w) {
00695     FindRec fr;
00696     fr.w = w;
00697     fr.wx = NULL;
00698     MrEdForEachFrame(IsWidgetFrame, &fr);
00699     return fr.wx;
00700   } else {
00701     wxWindow *m;
00702     Window root, parent, *children;
00703     unsigned int n, i;
00704     if (XQueryTree(d, xw, &root, &parent, &children, &n)) {
00705       if (children) {
00706        m = NULL;
00707        for (i = 0; i < n; i++) {
00708          m = FindMrEdWindow(d, children[i]);
00709          if (m)
00710            break;
00711        }
00712        XFree(children);
00713        return m;
00714       }
00715     }
00716      
00717     return NULL;
00718   }
00719 }
00720 
00721 wxWindow *wxLocationToWindow(int x, int y)
00722 {
00723   Display *d;
00724   Window root, parent, *children;
00725   unsigned int n, i;
00726   XWindowAttributes a;
00727   wxWindow *result = NULL;
00728 
00729   if (!orig_top_level)
00730     d = XtDisplay(save_top_level);
00731   else
00732     d = XtDisplay(orig_top_level);
00733 
00734   if (XQueryTree(d, DefaultRootWindow(d),
00735                &root, &parent, &children, &n)) {
00736     for (i = n; i--; ) {
00737       XGetWindowAttributes(d, children[i], &a);
00738 
00739       if (a.map_state == IsViewable
00740          && (a.x <= x) && (a.x + a.width >= x)
00741          && (a.y <= y) && (a.y + a.height >= y)) {
00742        /* Found the X window, now see if it's a MrEd window: */
00743        result = FindMrEdWindow(d, children[i]);
00744        break;
00745       }
00746     }
00747     
00748     if (children)
00749       XFree(children);
00750   }
00751  
00752  return result;
00753 }
00754 
00755 int wxLocaleStringToChar(char *str, int slen)
00756 {
00757   Scheme_Object *s;
00758   s = scheme_make_locale_string(str);
00759   if (SCHEME_CHAR_STRLEN_VAL(s))
00760     return SCHEME_CHAR_STR_VAL(s)[0];
00761   else
00762     return 0;
00763 }
00764 
00765 int wxUTF8StringToChar(char *str, int slen)
00766 {
00767   mzchar s[1];
00768   s[0] = 0;
00769   scheme_utf8_decode((unsigned char *)str, 0, slen,
00770                    s, 0, 1,
00771                    NULL, 0, '?');
00772   return (int)s[0];
00773 }
00774 
00775 /***********************************************************************/
00776 
00777 static int has_property(Display *d, Window w, Atom atag)
00778 {
00779   Atom actual;
00780   int format;
00781   unsigned long count, remaining;
00782   unsigned char *data = 0;
00783 
00784   XGetWindowProperty(d, w, atag,
00785                    0, 0x8000000L, FALSE, 
00786                    AnyPropertyType, &actual, &format,
00787                    &count, &remaining, &data);
00788 
00789   if (data)
00790     XFree(data);
00791 
00792   return (actual != None);
00793 }
00794 
00795 static int wxSendOrSetTag(char *tag, char *pre_tag, char *msg)
00796 {
00797   Display *d;
00798   Window root, parent, *children;
00799   unsigned int n, i;
00800   Atom atag, apre_tag;
00801   Window target = 0, me;
00802   int try_again = 0, add_property_back = 0, found_nothing;
00803 
00804   /* Elect a leader, relying on the fact that the X server serializes
00805      its interactions.
00806      
00807      Each client sets a pre-tag, and then checks all windows. If any
00808      window has a (non-pre) tag already, then that's the leader. If no
00809      one else has a pre tag, then this client is elected, and it sets
00810      the tag on itself.  If someone else has a pre tag, we try again;
00811      if the other window id is lower, this client drops it pre tag, so
00812      that the other will be elected eventually.  Note that if two
00813      clients set a pre tag, then one must see the other (because
00814      neither looks until its tag is set). Livelock is a possibility if
00815      clients continuously appear with ever higher window ids, but that
00816      possibility is exceedingly remote. */
00817 
00818   if (!orig_top_level)
00819     d = XtDisplay(save_top_level);
00820   else
00821     d = XtDisplay(orig_top_level);
00822 
00823   apre_tag = XInternAtom(d, pre_tag, False);
00824   atag = XInternAtom(d, tag, False);
00825 
00826   wx_single_instance_tag = atag;
00827 
00828   me = wxAddClipboardWindowProperty(apre_tag);
00829 
00830 
00831   do {
00832     if (add_property_back) {
00833       wxAddClipboardWindowProperty(apre_tag);
00834       add_property_back = 1;
00835     }
00836 
00837     XFlush(d);
00838     XSync(d, FALSE);
00839     
00840     found_nothing = 1;
00841 
00842     if (XQueryTree(d, DefaultRootWindow(d),
00843                  &root, &parent, &children, &n)) {
00844       for (i = n; i--; ) {
00845        if (children[i] != me) {
00846          if (has_property(d, children[i], atag)) {
00847            /* Found the leader: */
00848            target = children[i];
00849            try_again = 0;
00850            found_nothing = 0;
00851            break;
00852          } else if (has_property(d, children[i], apre_tag)) {
00853            /* Found another candidate. If our ID is
00854               higher, then withdrawl candidacy. Loop
00855               to wait for some process to assume leadership. */
00856            if ((long)me >= (long)children[i])
00857              XDeleteProperty(d, me, apre_tag);
00858            try_again = 1;
00859            found_nothing = 0;
00860          }
00861        }
00862       }
00863       
00864       if (found_nothing && try_again) {
00865        /* This can only happen if some candidate process
00866           (with a lower window ID) has now exited. Try 
00867           again to become the leader. */
00868        add_property_back = 1;
00869       }
00870       
00871       if (children)
00872        XFree(children);
00873     }
00874   } while (try_again);
00875 
00876   if (target) {
00877     GC_CAN_IGNORE XEvent xevent;
00878     long mlen, offset = 0;
00879     int sent_last = 0;
00880 
00881     mlen = strlen(msg);
00882 
00883     /* Send the message(s): */
00884     while (!sent_last) {
00885       memset(&xevent, 0, sizeof (xevent));
00886       
00887       xevent.xany.type = ClientMessage;
00888       xevent.xany.display = d;
00889       xevent.xclient.window = target;
00890       xevent.xclient.message_type = atag;
00891       xevent.xclient.format = 8;
00892 
00893       {
00894        int i = sizeof(Window);
00895        long w = (long)me;
00896 
00897        while (i--) {
00898          xevent.xclient.data.b[i] = (char)(w & 0xFF);
00899          w = w >> 8;
00900        }
00901       }
00902 
00903       if (offset < mlen) {
00904        long amt;
00905        amt = mlen - offset;
00906        if (amt > (int)(20 - sizeof(Window)))
00907          amt = 20 - sizeof(Window);
00908        memcpy(xevent.xclient.data.b + sizeof(Window), msg + offset, amt);
00909        offset += amt;
00910        sent_last = (amt < (int)(20 - sizeof(Window)));
00911       } else
00912        sent_last = 1;
00913 
00914       XSendEvent(d, target, 0, 0, &xevent);
00915     }
00916 
00917     XFlush(d);
00918     XSync(d, FALSE);
00919 
00920     return 1;
00921   } else {
00922     /* Set the property on the clipboard window */
00923     wxAddClipboardWindowProperty(atag);
00924 
00925     return 0;
00926   }
00927 }
00928 
00929 # define SINGLE_INSTANCE_HANDLER_CODE \
00930 "(lambda (f host)" \
00931 "  (let-values ([(path) (simplify-path" \
00932 "                        (path->complete-path" \
00933 "                         (or (find-executable-path (find-system-path 'run-file) #f)" \
00934 "                             (find-system-path 'run-file))" \
00935 "                         (current-directory)))])" \
00936 "    (let-values ([(tag) (string->bytes/utf-8" \
00937 "                         (format \"~a:~a_~a\" host path (version)))])" \
00938 "      (f tag " \
00939 "         (bytes-append #\"pre\" tag)" \
00940 "         (apply" \
00941 "          bytes-append" \
00942 "          (map (lambda (s)" \
00943 "                 (let-values ([(s) (path->string" \
00944 "                                    (path->complete-path s (current-directory)))])" \
00945 "                   (string->bytes/utf-8" \
00946 "                    (format \"~a:~a\"" \
00947 "                            (string-length s)" \
00948 "                            s))))" \
00949 "               (vector->list" \
00950 "                (current-command-line-arguments))))))))"
00951 
00952 static Scheme_Object *prep_single_instance(int argc, Scheme_Object **argv)
00953 {
00954   return (wxSendOrSetTag(SCHEME_BYTE_STR_VAL(argv[0]),
00955                       SCHEME_BYTE_STR_VAL(argv[1]),
00956                       SCHEME_BYTE_STR_VAL(argv[2]))
00957          ? scheme_true
00958          : scheme_false);
00959 }
00960 
00961 int wxCheckSingleInstance(Scheme_Env *global_env)
00962 {
00963   Scheme_Object *a[2], *v, *nam, *nr, *ns;
00964   char buf[256];
00965   Scheme_Config *config;
00966   Scheme_Cont_Frame_Data frame;
00967 
00968   if (!wxGetHostName(buf, 256)) {
00969     buf[0] = 0;
00970   }
00971 
00972   /* ************************************************************ */
00973   /* Set up a namespace to evaluate SINGLE_INSTANCE_HANDLER_CODE: */
00974   ns = scheme_make_namespace(0, NULL);
00975 
00976   config = scheme_extend_config(scheme_current_config(),
00977                                 MZCONFIG_ENV,
00978                                 ns);
00979   scheme_push_continuation_frame(&frame);
00980   scheme_install_config(config);
00981 
00982   nam = scheme_builtin_value("namespace-attach-module");
00983   a[0] = (Scheme_Object *)global_env;
00984   a[1] = scheme_make_pair(scheme_intern_symbol("quote"),
00985                           scheme_make_pair(scheme_intern_symbol("#%utils"),
00986                                            scheme_null));
00987   scheme_apply(nam, 2, a);
00988 
00989   nr = scheme_builtin_value("namespace-require");
00990   a[0] = a[1];
00991   scheme_apply(nr, 1, a);
00992 
00993   a[0] = scheme_make_pair(scheme_intern_symbol("quote"),
00994                           scheme_make_pair(scheme_intern_symbol("#%min-stx"),
00995                                            scheme_null));
00996   scheme_apply(nr, 1, a);
00997 
00998   a[0] = scheme_make_pair(scheme_intern_symbol("quote"),
00999                           scheme_make_pair(scheme_intern_symbol("#%kernel"),
01000                                            scheme_null));
01001   scheme_apply(nr, 1, a);
01002   /* *********************************************************** **/
01003 
01004   a[0] = scheme_make_prim(prep_single_instance);
01005   a[1] = scheme_make_byte_string(buf);
01006   v = scheme_apply(scheme_eval_string(SINGLE_INSTANCE_HANDLER_CODE,
01007                                   (Scheme_Env *)ns),
01008                  2,
01009                  a);
01010 
01011   /* Pop the namespace: */
01012   scheme_pop_continuation_frame(&frame);
01013 
01014   return SCHEME_TRUEP(v);
01015 }