Cleaning up X11 backend and adding close box support

TODO.FACTOR.txt

@@ -13,6 +13,7 @@
 + io:
 
 - httpd fep
+- httpd timeouts too quickly?
 - stream server can hang because of exception handler limitations
 - better i/o scheduler
 - out of memory error when printing global namespace

library/x11/events.factor

@@ -0,0 +1,50 @@
+! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+IN: x11
+USING: alien arrays errors gadgets hashtables io kernel math
+namespaces prettyprint sequences threads ;
+
+GENERIC: expose-event ( event window -- )
+
+GENERIC: resize-event ( event window -- )
+
+GENERIC: button-down-event ( event window -- )
+
+GENERIC: button-up-event ( event window -- )
+
+GENERIC: motion-event ( event window -- )
+
+GENERIC: key-event ( event window -- )
+
+GENERIC: client-event ( event window -- )
+
+: next-event ( -- event )
+    dpy get "XEvent" <c-object> dup >r XNextEvent drop r> ;
+
+: mask-event ( mask -- event )
+    >r dpy get r> "XEvent" <c-object> dup >r XMaskEvent drop r> ;
+
+: events-queued ( mode -- n ) >r dpy get r> XEventsQueued ;
+
+: next-event ( -- event )
+    dpy get "XEvent" <c-object> dup >r XNextEvent drop r> ;
+
+: wait-event ( -- event )
+    QueuedAfterFlush events-queued 0 >
+    [ next-event ] [ ui-step wait-event ] if ;
+
+: handle-event ( event window -- )
+    over XAnyEvent-type {
+        { [ dup Expose = ] [ drop expose-event ] }
+        { [ dup ConfigureNotify = ] [ drop resize-event ] }
+        { [ dup ButtonPress = ] [ drop button-down-event ] }
+        { [ dup ButtonRelease = ] [ drop button-up-event ] }
+        { [ dup MotionNotify = ] [ drop motion-event ] }
+        { [ dup KeyPress = ] [ drop key-event ] }
+        { [ dup ClientMessage = ] [ drop client-event ] }
+        { [ t ] [ 3drop ] }
+    } cond ;
+
+: event-loop ( -- )
+    wait-event dup XAnyEvent-window windows get hash dup
+    [ handle-event ] [ 2drop ] if event-loop ;

library/x11/glx-utils.factor

@@ -0,0 +1,18 @@
+! Copyright (C) 2005, 2006 Eduardo Cavazos
+! See http://factorcode.org/license.txt for BSD license.
+IN: x11
+USING: alien arrays errors kernel namespaces sequences ;
+
+: >int-array ( seq -- <int-array> )
+    dup length dup "int" <c-array> -rot
+    [ pick set-int-nth ] 2each ;
+
+: choose-visual ( -- XVisualInfo* )
+    dpy get scr get
+    GLX_RGBA GLX_DOUBLEBUFFER 0 3array >int-array
+    glXChooseVisual
+    [ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ;
+
+: create-context ( XVisualInfo* -- GLXContext )
+    >r dpy get r> f 1 glXCreateContext
+    [ "Failed to create GLX context" throw ] unless* ;

library/x11/load.factor

@@ -7,6 +7,9 @@ USING: kernel parser words compiler sequences ;
     "/library/x11/glx.factor"
     "/library/x11/constants.factor"
     "/library/x11/utilities.factor"
+    "/library/x11/events.factor"
+    "/library/x11/windows.factor"
+    "/library/x11/glx-utils.factor"
     "/library/x11/ui.factor"
 } [ run-resource ] each
 

library/x11/ui.factor

@@ -1,8 +1,14 @@
+! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
 IN: x11
 USING: arrays errors freetype gadgets gadgets-launchpad
 gadgets-layouts gadgets-listener hashtables kernel
 kernel-internals math namespaces opengl sequences x11 ;
 
+! In the X11 backend, world-handle is a pair { window context }.
+! The window is an X11 window ID, and the context is a
+! GLX context pointer.
+
 M: world expose-event ( event world -- ) nip draw-world ;
 
 M: world resize-event ( event world -- )
@@ -23,9 +29,21 @@ M: world motion-event ( event world -- )
 
 M: world key-event ( event world -- ) 2drop ;
 
+: close-box? ( event -- )
+    dup XClientMessageEvent-type "WM_PROTOCOLS" x-atom =
+    swap XClientMessageEvent-data "WM_DELETE_WINDOW" x-atom =
+    and ;
+
+M: world client-event ( event world -- )
+    swap close-box? [
+        dup close-world world-handle destroy-window*
+    ] [
+        drop
+    ] if ;
+
 : gadget-window ( world -- window )
     dup rect-dim first2 choose-visual [
-        create-window 2dup windows get set-hash dup map-window
+        create-window 2dup map-window*
     ] keep create-context 2array swap set-world-handle ;
 
 IN: gadgets

library/x11/utilities.factor

@@ -4,125 +4,19 @@ IN: x11
 USING: alien arrays errors gadgets hashtables io kernel math
 namespaces prettyprint sequences threads ;
 
+! Global variable; maps X11 window handles to objects responding
+! to the event protocol in /library/x11/events.factor
+SYMBOL: windows
+
 SYMBOL: dpy
 SYMBOL: scr
 SYMBOL: root
 
-! Window management
-: create-window-mask ( -- n )
-    CWBackPixel CWBorderPixel bitor
-    CWColormap bitor CWEventMask bitor ;
-
-: create-colormap ( visinfo -- colormap )
-    dpy get root get rot XVisualInfo-visual AllocNone
-    XCreateColormap ;
-
-: event-mask ( -- n )
-    StructureNotifyMask ExposureMask bitor 
-    KeyPressMask bitor
-    KeyReleaseMask bitor
-    ButtonPressMask	bitor
-    ButtonReleaseMask bitor
-    PointerMotionMask bitor ;
-
-: window-attributes ( visinfo -- attributes )
-    "XSetWindowAttributes" <c-object>
-    0 over set-XSetWindowAttributes-background_pixel
-    0 over set-XSetWindowAttributes-border_pixel
-    [ >r create-colormap r> set-XSetWindowAttributes-colormap ] keep
-    event-mask over set-XSetWindowAttributes-event_mask ;
-
-: create-window ( w h visinfo -- window )
-    >r >r >r dpy get root get 0 0 r> r> 0 r>
-    [ XVisualInfo-depth InputOutput ] keep
-    [ XVisualInfo-visual create-window-mask ] keep
-    window-attributes XCreateWindow ;
-
-: destroy-window ( win -- )
-    dpy get swap XDestroyWindow drop ;
-
-: map-window ( win -- )
-    dpy get swap XMapWindow drop ;
-
-: map-subwindows ( win -- )
-    dpy get swap XMapSubwindows drop ;
-
-: unmap-window ( win -- )
-    dpy get swap XUnmapWindow drop ;
-
-: unmap-subwindows ( win -- )
-    dpy get swap XUnmapSubwindows drop ;
-
-! Event handling
-
-: select-input ( win mask -- )
-    >r dpy get swap r> XSelectInput drop ;
-
 : flush-dpy ( -- ) dpy get XFlush drop ;
 
 : sync-dpy ( discard -- ) >r dpy get r> XSync ;
 
-: next-event ( -- event )
+: x-atom ( string -- atom ) dpy get swap 0 XInternAtom ;
-    dpy get "XEvent" <c-object> dup >r XNextEvent drop r> ;
-
-: mask-event ( mask -- event )
-    >r dpy get r> "XEvent" <c-object> dup >r XMaskEvent drop r> ;
-
-: events-queued ( mode -- n ) >r dpy get r> XEventsQueued ;
-
-: next-event ( -- event )
-    dpy get "XEvent" <c-object> dup >r XNextEvent drop r> ;
-
-: wait-event ( -- event )
-    QueuedAfterFlush events-queued 0 >
-    [ next-event ] [ ui-step wait-event ] if ;
-
-GENERIC: expose-event ( event window -- )
-
-GENERIC: resize-event ( event window -- )
-
-GENERIC: button-down-event ( event window -- )
-
-GENERIC: button-up-event ( event window -- )
-
-GENERIC: motion-event ( event window -- )
-
-GENERIC: key-event ( event window -- )
-
-: handle-event ( event window -- )
-    over XAnyEvent-type {
-        { [ dup Expose = ] [ drop expose-event ] }
-        { [ dup ConfigureNotify = ] [ drop resize-event ] }
-        { [ dup ButtonPress = ] [ drop button-down-event ] }
-        { [ dup ButtonRelease = ] [ drop button-up-event ] }
-        { [ dup MotionNotify = ] [ drop motion-event ] }
-        { [ dup KeyPress = ] [ drop key-event ] }
-        { [ t ] [ 3drop ] }
-    } cond ;
-
-SYMBOL: windows
-
-: event-loop ( -- )
-    wait-event dup XAnyEvent-window windows get hash dup
-    [ handle-event ] [ 2drop ] if event-loop ;
-
-! GLX
-
-: >int-array ( seq -- <int-array> )
-    dup length dup "int" <c-array> -rot
-    [ pick set-int-nth ] 2each ;
-
-: choose-visual ( -- XVisualInfo* )
-    dpy get scr get
-    GLX_RGBA GLX_DOUBLEBUFFER 0 3array >int-array
-    glXChooseVisual
-    [ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ;
-
-: create-context ( XVisualInfo* -- GLXContext )
-    >r dpy get r> f 1 glXCreateContext
-    [ "Failed to create GLX context" throw ] unless* ;
-
-! Initialization
 
 : check-display
     [ "Cannot connect to X server - check $DISPLAY" throw ] unless* ;

library/x11/windows.factor

@@ -0,0 +1,54 @@
+! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+IN: x11
+USING: alien hashtables kernel math namespaces ;
+
+: create-window-mask ( -- n )
+    CWBackPixel CWBorderPixel bitor
+    CWColormap bitor CWEventMask bitor ;
+
+: create-colormap ( visinfo -- colormap )
+    dpy get root get rot XVisualInfo-visual AllocNone
+    XCreateColormap ;
+
+: event-mask ( -- n )
+    StructureNotifyMask ExposureMask bitor 
+    KeyPressMask bitor
+    KeyReleaseMask bitor
+    ButtonPressMask	bitor
+    ButtonReleaseMask bitor
+    PointerMotionMask bitor ;
+
+: window-attributes ( visinfo -- attributes )
+    "XSetWindowAttributes" <c-object>
+    0 over set-XSetWindowAttributes-background_pixel
+    0 over set-XSetWindowAttributes-border_pixel
+    [ >r create-colormap r> set-XSetWindowAttributes-colormap ] keep
+    event-mask over set-XSetWindowAttributes-event_mask ;
+
+: create-window ( w h visinfo -- window )
+    >r >r >r dpy get root get 0 0 r> r> 0 r>
+    [ XVisualInfo-depth InputOutput ] keep
+    [ XVisualInfo-visual create-window-mask ] keep
+    window-attributes XCreateWindow ;
+
+: destroy-window ( win -- )
+    dpy get swap XDestroyWindow drop ;
+
+: destroy-window* ( win -- )
+    dup windows get remove-hash destroy-window ;
+
+: map-window ( win -- )
+    dpy get swap XMapWindow drop ;
+
+: map-window* ( world win -- )
+    [ windows get set-hash ] keep map-window ;
+
+: map-subwindows ( win -- )
+    dpy get swap XMapSubwindows drop ;
+
+: unmap-window ( win -- )
+    dpy get swap XUnmapWindow drop ;
+
+: unmap-subwindows ( win -- )
+    dpy get swap XUnmapSubwindows drop ;

library/x11/xlib.factor

@@ -937,6 +937,7 @@ BEGIN-STRUCT: XClientMessageEvent
 	FIELD: Window window
 	FIELD: Atom message_type
 	FIELD: int format
+    FIELD: long data
 !       union {
 ! 		char  b[20];
 ! 		short s[10];