basis/ui/backend/x11/x11.factor

   1 ! Copyright (C) 2005, 2010 Eduardo Cavazos, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types alien.data alien.syntax arrays ascii
   4 assocs classes.struct combinators combinators.short-circuit
   5 environment io.encodings.ascii io.encodings.string io.encodings.utf8
   6 kernel literals locals math namespaces sequences specialized-arrays
   7 strings ui ui.backend ui.backend.x11.keys ui.clipboards ui.event-loop
   8 ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
   9 ui.pixel-formats ui.private x11 x11.X x11.clipboard x11.events x11.glx
  10 x11.io x11.windows x11.xim x11.xlib ;
  11 FROM: libc => system ;
  12 SPECIALIZED-ARRAYS: uchar ulong ;
  13 IN: ui.backend.x11
  14
  15 SINGLETON: x11-ui-backend
  16
  17 ! *****************************************************************
  18 ! * EXTENDED WINDOW MANAGER HINTS
  19 ! *****************************************************************
  20
  21 CONSTANT: _NET_WM_STATE_REMOVE 0
  22 CONSTANT: _NET_WM_STATE_ADD 1
  23 CONSTANT: _NET_WM_STATE_TOGGLE 2
  24
  25 : XA_NET_SUPPORTED ( -- atom ) "_NET_SUPPORTED" x-atom ;
  26 : XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
  27 : XA_NET_WM_STATE ( -- atom ) "_NET_WM_STATE" x-atom ;
  28 : XA_NET_WM_STATE_FULLSCREEN ( -- atom ) "_NET_WM_STATE_FULLSCREEN" x-atom ;
  29 : XA_NET_ACTIVE_WINDOW ( -- atom ) "_NET_ACTIVE_WINDOW" x-atom ;
  30
  31 :: get-atom-properties ( window name -- seq )
  32     { Atom int ulong ulong pointer: Atom }
  33     [| type format n-atoms bytes-after atoms |
  34         dpy get
  35         window
  36         name
  37         0
  38         ulong c-type-interval nip
  39         0
  40         XA_ATOM
  41         type
  42         format
  43         n-atoms
  44         bytes-after
  45         atoms
  46         XGetWindowProperty
  47         Success assert=
  48     ]
  49     with-out-parameters
  50     [| type format n-atoms bytes-after atoms |
  51         atoms n-atoms ulong <c-direct-array> >array
  52         atoms XFree
  53     ] call ;
  54
  55 : supported-net-wm-hints ( -- seq )
  56     root get XA_NET_SUPPORTED get-atom-properties ;
  57
  58 : net-wm-hint-supported? ( atom -- ? )
  59     supported-net-wm-hints member? ;
  60
  61 TUPLE: x11-handle-base glx ;
  62 TUPLE: x11-handle < x11-handle-base window xic ;
  63
  64 C: <x11-handle> x11-handle
  65
  66 M: world expose-event nip relayout ;
  67
  68 M: world configure-event
  69     swap [ event-loc >>window-loc ] [ event-dim >>dim ] bi
  70     t >>active?
  71     ! In case dimensions didn't change
  72     relayout-1 ;
  73
  74 CONSTANT: perm-attribs { $ GLX_RGBA }
  75 CONSTANT: attrib-table H{
  76     { double-buffered { $ GLX_DOUBLEBUFFER } }
  77     { stereo { $ GLX_STEREO } }
  78     { color-bits { $ GLX_BUFFER_SIZE } }
  79     { red-bits { $ GLX_RED_SIZE } }
  80     { green-bits { $ GLX_GREEN_SIZE } }
  81     { blue-bits { $ GLX_BLUE_SIZE } }
  82     { alpha-bits { $ GLX_ALPHA_SIZE } }
  83     { accum-red-bits { $ GLX_ACCUM_RED_SIZE } }
  84     { accum-green-bits { $ GLX_ACCUM_GREEN_SIZE } }
  85     { accum-blue-bits { $ GLX_ACCUM_BLUE_SIZE } }
  86     { accum-alpha-bits { $ GLX_ACCUM_ALPHA_SIZE } }
  87     { depth-bits { $ GLX_DEPTH_SIZE } }
  88     { stencil-bits { $ GLX_STENCIL_SIZE } }
  89     { aux-buffers { $ GLX_AUX_BUFFERS } }
  90     { sample-buffers { $ GLX_SAMPLE_BUFFERS } }
  91     { samples { $ GLX_SAMPLES } }
  92 }
  93
  94 M: x11-ui-backend (make-pixel-format)
  95     [ drop dpy get scr get ] dip perm-attribs attrib-table
  96     pixel-format-attributes>int-array glXChooseVisual ;
  97
  98 M: x11-ui-backend (free-pixel-format)
  99     handle>> XFree ;
 100
 101 : key-code ( code -- string/f action? )
 102     code>sym [ dup integer? [ 1string ] when ] dip ;
 103
 104 : valid-input? ( string gesture -- ? )
 105     over empty? [ 2drop f ] [
 106         mods>> { f { S+ } } member? [
 107             [ { [ 127 = not ] [ CHAR: \s >= ] } 1&& ] all?
 108         ] [
 109             [ { [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] } 1&& ] all?
 110         ] if
 111     ] if ;
 112
 113 : key-down-event>gesture ( event world -- string gesture )
 114     dupd
 115     handle>> xic>> lookup-string
 116     [ swap event-modifiers ] dip key-code <key-down> ;
 117
 118 M: world key-down-event
 119     [ key-down-event>gesture ] keep
 120     [ propagate-key-gesture drop ]
 121     [ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
 122     3bi ;
 123
 124 : key-up-event>gesture ( event -- gesture )
 125     [ event-modifiers ] [ 0 XLookupKeysym key-code ] bi <key-up> ;
 126
 127 M: world key-up-event
 128     [ key-up-event>gesture ] dip propagate-key-gesture ;
 129
 130 : mouse-event>gesture ( event -- modifiers button loc )
 131     [ event-modifiers ] [ button>> ] [ event-loc ] tri ;
 132
 133 M: world button-down-event
 134     [ mouse-event>gesture [ <button-down> ] dip ] dip
 135     send-button-down ;
 136
 137 M: world button-up-event
 138     [ mouse-event>gesture [ <button-up> ] dip ] dip
 139     send-button-up ;
 140
 141 : mouse-event>scroll-direction ( event -- pair )
 142     button>> {
 143         { 4 { 0 -1 } }
 144         { 5 { 0 1 } }
 145         { 6 { -1 0 } }
 146         { 7 { 1 0 } }
 147     } at ;
 148
 149 M: world scroll-event
 150     [ [ mouse-event>scroll-direction ] [ event-loc ] bi ] dip
 151     send-scroll ;
 152
 153 M: world enter-event motion-event ;
 154
 155 M: world leave-event 2drop forget-rollover ;
 156
 157 M: world motion-event
 158     [ event-loc ] dip move-hand fire-motion ;
 159
 160 M: world focus-in-event
 161     nip [ handle>> xic>> XSetICFocus ] [ focus-world ] bi ;
 162
 163 M: world focus-out-event
 164     nip [ handle>> xic>> XUnsetICFocus ] [ unfocus-world ] bi ;
 165
 166 M: world selection-notify-event
 167     [ handle>> window>> selection-from-event ] keep
 168     user-input ;
 169
 170 : supported-type? ( atom -- ? )
 171     XA_UTF8_STRING XA_STRING XA_TEXT 3array member? ;
 172
 173 : clipboard-for-atom ( atom -- clipboard )
 174     {
 175         { XA_PRIMARY [ selection get ] }
 176         { XA_CLIPBOARD [ clipboard get ] }
 177         [ drop <clipboard> ]
 178     } case ;
 179
 180 : encode-clipboard ( string type -- bytes )
 181     target>> XA_UTF8_STRING = utf8 ascii ? encode ;
 182
 183 : set-selection-prop ( evt -- )
 184     dpy get swap
 185     [ requestor>> ] keep
 186     [ property>> ] keep
 187     [ target>> 8 PropModeReplace ] keep
 188     [ selection>> clipboard-for-atom contents>> ] keep
 189     encode-clipboard dup length XChangeProperty drop ;
 190
 191 M: world selection-request-event
 192     drop dup target>> {
 193         { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
 194         { [ dup XA_TARGETS = ] [ drop dup set-targets-prop send-notify-success ] }
 195         { [ dup XA_TIMESTAMP = ] [ drop dup set-timestamp-prop send-notify-success ] }
 196         [ drop send-notify-failure ]
 197     } cond ;
 198
 199 M: x11-ui-backend (close-window) ( handle -- )
 200     [ xic>> XDestroyIC ]
 201     [ glx>> destroy-glx ]
 202     [ window>> [ unregister-window ] [ destroy-window ] bi ]
 203     tri ;
 204
 205 M: world client-event
 206     swap close-box? [ ungraft ] [ drop ] if ;
 207
 208 : gadget-window ( world -- )
 209     dup
 210     [ [ [ window-loc>> ] [ dim>> ] bi ] dip handle>> glx-window ]
 211     with-world-pixel-format swap
 212     dup "Factor" create-xic
 213     <x11-handle>
 214     [ window>> register-window ] [ >>handle drop ] 2bi ;
 215
 216 : wait-event ( -- event )
 217     QueuedAfterFlush events-queued 0 > [
 218         next-event dup
 219         None XFilterEvent 0 = [ drop wait-event ] unless
 220     ] [ wait-for-display wait-event ] if ;
 221
 222 M: x11-ui-backend do-events
 223     wait-event dup XAnyEvent>> window>> window dup
 224     [ handle-event ] [ 2drop ] if ;
 225
 226 : x-clipboard@ ( gadget clipboard -- prop win )
 227     atom>> swap
 228     find-world handle>> window>> ;
 229
 230 M: x-clipboard copy-clipboard
 231     [ x-clipboard@ own-selection ] keep
 232     contents<< ;
 233
 234 M: x-clipboard paste-clipboard
 235     [ find-world handle>> window>> ] dip atom>> convert-selection ;
 236
 237 : init-clipboard ( -- )
 238     XA_PRIMARY <x-clipboard> selection set-global
 239     XA_CLIPBOARD <x-clipboard> clipboard set-global ;
 240
 241 : set-title-old ( dpy window string -- )
 242     dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
 243
 244 : set-title-new ( dpy window string -- )
 245     [ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
 246     utf8 encode dup length XChangeProperty drop ;
 247
 248 : set-class ( dpy window -- )
 249     XA_WM_CLASS XA_UTF8_STRING 8 PropModeReplace "Factor"
 250     utf8 encode dup length XChangeProperty drop ;
 251
 252 M: x11-ui-backend set-title ( string world -- )
 253     handle>> window>> swap
 254     [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
 255
 256 : make-fullscreen-msg ( window ? -- msg )
 257     XClientMessageEvent <struct>
 258         ClientMessage >>type
 259         dpy get >>display
 260         XA_NET_WM_STATE >>message_type
 261         swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
 262         swap >>window
 263         32 >>format
 264         XA_NET_WM_STATE_FULLSCREEN >>data1 ;
 265
 266 : send-event ( event -- )
 267     [
 268         dpy get
 269         root get
 270         0
 271         flags{ SubstructureNotifyMask SubstructureRedirectMask }
 272     ] dip XSendEvent drop ;
 273
 274 M: x11-ui-backend (set-fullscreen) ( world ? -- )
 275     [ handle>> window>> ] dip make-fullscreen-msg send-event ;
 276
 277 M: x11-ui-backend (fullscreen?) ( world -- ? )
 278     handle>> window>> XA_NET_WM_STATE get-atom-properties
 279     XA_NET_WM_STATE_FULLSCREEN swap member? ;
 280
 281 M: x11-ui-backend (open-window) ( world -- )
 282     dup gadget-window handle>> window>>
 283     [ set-closable ]
 284     [ [ dpy get ] dip set-class ]
 285     [ map-window ]
 286     tri ;
 287
 288 : make-raise-window-msg ( window -- msg )
 289     XClientMessageEvent <struct>
 290         ClientMessage >>type
 291         1 >>send_event
 292         dpy get >>display
 293         swap >>window
 294         XA_NET_ACTIVE_WINDOW >>message_type
 295         32 >>format ;
 296
 297 : raise-window-new ( window -- )
 298     make-raise-window-msg send-event ;
 299
 300 : raise-window-old ( window -- )
 301     [ dpy get ] dip
 302     [ RevertToPointerRoot CurrentTime XSetInputFocus drop ]
 303     [ XRaiseWindow drop ]
 304     2bi ;
 305
 306 M: x11-ui-backend raise-window* ( world -- )
 307     handle>> [
 308         window>>
 309         XA_NET_ACTIVE_WINDOW net-wm-hint-supported?
 310         [ raise-window-new ] [ raise-window-old ] if
 311     ] when* ;
 312
 313 M: x11-handle select-gl-context ( handle -- )
 314     dpy get swap
 315     [ window>> ] [ glx>> ] bi glXMakeCurrent
 316     [ "Failed to set current GLX context" throw ] unless ;
 317
 318 M: x11-handle flush-gl-context ( handle -- )
 319     dpy get swap window>> glXSwapBuffers ;
 320
 321 M: x11-ui-backend (with-ui) ( quot -- )
 322     f [
 323         [
 324             init-clipboard
 325             start-ui
 326             event-loop
 327         ] with-xim
 328     ] with-x ;
 329
 330 M: x11-ui-backend beep ( -- )
 331     dpy get 100 XBell drop ;
 332
 333 <PRIVATE
 334 : escape-' ( string -- string' )
 335     [ dup CHAR: ' = [ drop "'\\''" ] [ 1string ] if ] { } map-as concat ;
 336
 337 : xmessage ( string -- )
 338     escape-' "/usr/bin/env xmessage '" "'" surround system drop ;
 339 PRIVATE>
 340
 341 M: x11-ui-backend system-alert
 342     "\n\n" glue xmessage ;
 343
 344 : black ( -- xcolor ) 0 0 0 0 0 0 XColor <struct-boa> ; inline
 345
 346 M:: x11-ui-backend (grab-input) ( handle -- )
 347     handle window>>                                                  :> wnd
 348     dpy get                                                          :> dpy
 349     dpy wnd uchar-array{ 0 0 0 0 0 0 0 0 } 8 8 XCreateBitmapFromData :> pixmap
 350     dpy pixmap dup black dup 0 0 XCreatePixmapCursor                 :> cursor
 351
 352     dpy wnd 1 NoEventMask GrabModeAsync dup wnd cursor CurrentTime XGrabPointer drop
 353
 354     dpy cursor XFreeCursor drop
 355     dpy pixmap XFreePixmap drop ;
 356
 357 M: x11-ui-backend (ungrab-input)
 358     drop dpy get CurrentTime XUngrabPointer drop ;
 359
 360 x11-ui-backend ui-backend set-global
 361
 362 M: x11-ui-backend ui-backend-available?
 363     "DISPLAY" os-env >boolean ;
 364
 365 M: x11-ui-backend resize-window
 366     [ dpy get ] 2dip [ handle>> window>> ] [ first2 ] bi* XResizeWindow drop ;