diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index 4e69455865..61441b7f35 100644 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@ -1,20 +1,52 @@ -! Copyright (C) 2005, 2010 Eduardo Cavazos and Slava Pestov +! Copyright (C) 2005, 2010 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types alien.data ascii assocs classes.struct -combinators combinators.short-circuit command-line environment -io.encodings.ascii io.encodings.string io.encodings.utf8 kernel -literals locals math namespaces sequences specialized-arrays -strings ui ui.backend ui.clipboards ui.event-loop ui.gadgets -ui.gadgets.private ui.gadgets.worlds ui.gestures ui.pixel-formats -ui.pixel-formats.private ui.private x11 x11.clipboard x11.constants -x11.events x11.glx x11.io x11.windows x11.xim x11.xlib ; -FROM: unix.ffi => system ; -SPECIALIZED-ARRAY: uchar +USING: accessors arrays alien.c-types alien.data alien.syntax ascii +assocs classes.struct combinators combinators.short-circuit +command-line environment io.encodings.ascii io.encodings.string +io.encodings.utf8 kernel literals locals math namespaces +sequences specialized-arrays strings ui ui.backend ui.clipboards +ui.event-loop ui.gadgets ui.gadgets.private ui.gadgets.worlds +ui.gestures ui.pixel-formats ui.pixel-formats.private ui.private +x11 x11.clipboard x11.constants x11.events x11.glx x11.io +x11.windows x11.xim x11.xlib ; +FROM: libc => system ; +SPECIALIZED-ARRAYS: uchar ulong ; IN: ui.backend.x11 SINGLETON: x11-ui-backend +: XA_NET_SUPPORTED ( -- atom ) "_NET_SUPPORTED" x-atom ; : XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ; +: XA_NET_WM_STATE ( -- atom ) "_NET_WM_STATE" x-atom ; +: XA_NET_WM_STATE_FULLSCREEN ( -- atom ) "_NET_WM_STATE_FULLSCREEN" x-atom ; +: XA_NET_ACTIVE_WINDOW ( -- atom ) "_NET_ACTIVE_WINDOW" x-atom ; + +: supported-net-wm-hints ( -- seq ) + { Atom int ulong ulong pointer: Atom } + [| type format n-atoms bytes-after atoms | + dpy get + root get + XA_NET_SUPPORTED + 0 + ulong c-type-interval nip + 0 + XA_ATOM + type + format + n-atoms + bytes-after + atoms + XGetWindowProperty + Success assert= + ] + [| type format n-atoms bytes-after atoms | + atoms ulong-array-cast >array + atoms XFree + ] + with-out-parameters ; + +: net-wm-hint-supported? ( atom -- ? ) + supported-net-wm-hints member? ; TUPLE: x11-handle-base glx ; TUPLE: x11-handle < x11-handle-base window xic ; @@ -172,8 +204,7 @@ M: world selection-notify-event user-input ; : supported-type? ( atom -- ? ) - { "UTF8_STRING" "STRING" "TEXT" } - [ x-atom = ] with any? ; + XA_UTF8_STRING XA_STRING XA_TEXT 3array member? ; : clipboard-for-atom ( atom -- clipboard ) { @@ -196,8 +227,8 @@ M: world selection-notify-event M: world selection-request-event drop dup target>> { { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] } - { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] } - { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] } + { [ dup XA_TARGETS = ] [ drop dup set-targets-prop send-notify-success ] } + { [ dup XA_TIMESTAMP = ] [ drop dup set-timestamp-prop send-notify-success ] } [ drop send-notify-failure ] } cond ; @@ -258,31 +289,57 @@ M: x11-ui-backend set-title ( string world -- ) handle>> window>> swap [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ; -: make-fullscreen-msg ( world ? -- msg ) +: make-fullscreen-msg ( window ? -- msg ) XClientMessageEvent - ClientMessage >>type - dpy get >>display - "_NET_WM_STATE" x-atom >>message_type - swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0 - swap handle>> window>> >>window - 32 >>format - "_NET_WM_STATE_FULLSCREEN" x-atom >>data1 ; + ClientMessage >>type + dpy get >>display + XA_NET_WM_STATE >>message_type + swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0 + swap >>window + 32 >>format + XA_NET_WM_STATE_FULLSCREEN >>data1 ; + +: send-event ( event -- ) + [ + dpy get + root get + 0 + SubstructureNotifyMask SubstructureRedirectMask bitor + ] dip XSendEvent drop ; M: x11-ui-backend (set-fullscreen) ( world ? -- ) - [ dpy get root get 0 SubstructureNotifyMask ] 2dip - make-fullscreen-msg XSendEvent drop ; + [ handle>> window>> ] dip make-fullscreen-msg send-event ; M: x11-ui-backend (open-window) ( world -- ) - dup gadget-window - handle>> window>> - [ set-closable ] [ dpy get swap set-class ] [ map-window ] tri ; + dup gadget-window handle>> window>> + [ set-closable ] + [ [ dpy get ] dip set-class ] + [ map-window ] + tri ; + +: make-raise-window-msg ( window -- msg ) + XClientMessageEvent + ClientMessage >>type + 1 >>send_event + dpy get >>display + swap >>window + XA_NET_ACTIVE_WINDOW >>message_type + 32 >>format ; + +: raise-window-new ( window -- ) + make-raise-window-msg send-event ; + +: raise-window-old ( window -- ) + [ dpy get ] dip + [ RevertToPointerRoot CurrentTime XSetInputFocus drop ] + [ XRaiseWindow drop ] + 2bi ; M: x11-ui-backend raise-window* ( world -- ) handle>> [ - dpy get swap window>> - [ RevertToPointerRoot CurrentTime XSetInputFocus drop ] - [ XRaiseWindow drop ] - 2bi + window>> + XA_NET_ACTIVE_WINDOW net-wm-hint-supported? + [ raise-window-new ] [ raise-window-old ] if ] when* ; M: x11-handle select-gl-context ( handle -- )