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