Cleaning up X11 backend and adding close box support
slava
parent
b40168c416
commit
df8d0b7013
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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* ;
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
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
|
||||
: x-atom ( string -- atom ) dpy get swap 0 XInternAtom ;
|
||||
|
||||
: check-display
|
||||
[ "Cannot connect to X server - check $DISPLAY" throw ] unless* ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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];
|
||||
|
|
|
|||
Loading…
Reference in New Issue