Updating code to use with-out-parameters

[factor.git] / basis / ui / backend / x11 / x11.factor

diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor
old mode 100755 (executable)
new mode 100644 (file)
index fcaf0e2..ef0618d
--- a/basis/ui/backend/x11/x11.factor
+++ b/basis/ui/backend/x11/x11.factor
@@ -1,13 +1,14 @@
-! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov
+! Copyright (C) 2005, 2010 Eduardo Cavazos and Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays ascii assocs
-classes.struct combinators io.encodings.ascii
-io.encodings.string io.encodings.utf8 kernel literals math
-namespaces sequences 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 environment command-line ;
+USING: accessors alien.c-types 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.instances.alien.c-types.uchar
+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 ;
 IN: ui.backend.x11
 
 SINGLETON: x11-ui-backend
@@ -59,7 +60,7 @@ M: x11-ui-backend (pixel-format-attribute)
     [ handle>> ] [ >glx-visual ] bi*
     [ 2drop f ] [
         first
-        0 <int> [ glXGetConfig drop ] keep *int
+        { int } [ glXGetConfig drop ] with-out-parameters
     ] if-empty ;
 
 CONSTANT: modifiers
@@ -106,9 +107,9 @@ CONSTANT: key-codes
 : valid-input? ( string gesture -- ? )
     over empty? [ 2drop f ] [
         mods>> { f { S+ } } member? [
-            [ [ 127 = not ] [ CHAR: \s >= ] bi and ] all?
+            [ { [ 127 = not ] [ CHAR: \s >= ] } 1&& ] all?
         ] [
-            [ [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] tri and and ] all?
+            [ { [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] } 1&& ] all?
         ] if
     ] if ;
 
@@ -148,9 +149,9 @@ M: world button-up-event
         { 7 { 1 0 } }
     } at ;
 
-M: world wheel-event
+M: world scroll-event
     [ [ mouse-event>scroll-direction ] [ event-loc ] bi ] dip
-    send-wheel ;
+    send-scroll ;
 
 M: world enter-event motion-event ;
 
@@ -223,7 +224,7 @@ M: world client-event
     ] [ wait-for-display wait-event ] if ;
 
 M: x11-ui-backend do-events
-    wait-event dup window>> window dup
+    wait-event dup XAnyEvent>> window>> window dup
     [ handle-event ] [ 2drop ] if ;
 
 : x-clipboard@ ( gadget clipboard -- prop win )
@@ -232,7 +233,7 @@ M: x11-ui-backend do-events
 
 M: x-clipboard copy-clipboard
     [ x-clipboard@ own-selection ] keep
-    (>>contents) ;
+    contents<< ;
 
 M: x-clipboard paste-clipboard
     [ find-world handle>> window>> ] dip atom>> convert-selection ;
@@ -256,15 +257,19 @@ M: x11-ui-backend set-title ( string world -- )
     handle>> window>> swap
     [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
 
-M: x11-ui-backend (set-fullscreen) ( world ? -- )
+: make-fullscreen-msg ( world ? -- msg )
     XClientMessageEvent <struct>
-    swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
-    swap handle>> window>> >>window
+    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
-    [ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
+    "_NET_WM_STATE_FULLSCREEN" x-atom >>data1 ;
+
+M: x11-ui-backend (set-fullscreen) ( world ? -- )
+    [ dpy get root get 0 SubstructureNotifyMask ] 2dip
+    make-fullscreen-msg XSendEvent drop ;
 
 M: x11-ui-backend (open-window) ( world -- )
     dup gadget-window
@@ -322,6 +327,33 @@ M: x11-ui-backend (with-ui) ( quot -- )
 M: x11-ui-backend beep ( -- )
     dpy get 100 XBell drop ;
 
+<PRIVATE
+: escape-' ( string -- string' )
+    [ dup CHAR: ' = [ drop "'\\''" ] [ 1string ] if ] { } map-as concat ;
+
+: xmessage ( string -- )
+    escape-' "/usr/bin/env xmessage '" "'" surround system drop ;
+PRIVATE>
+
+M: x11-ui-backend system-alert
+    "\n\n" glue xmessage ;
+
+: black ( -- xcolor ) 0 0 0 0 0 0 XColor <struct-boa> ; inline
+
+M:: x11-ui-backend (grab-input) ( handle -- )
+    handle window>>                                                  :> wnd
+    dpy get                                                          :> dpy
+    dpy wnd uchar-array{ 0 0 0 0 0 0 0 0 } 8 8 XCreateBitmapFromData :> pixmap
+    dpy pixmap dup black dup 0 0 XCreatePixmapCursor                 :> cursor
+
+    dpy wnd 1 NoEventMask GrabModeAsync dup wnd cursor CurrentTime XGrabPointer drop
+
+    dpy cursor XFreeCursor drop
+    dpy pixmap XFreePixmap drop ;
+
+M: x11-ui-backend (ungrab-input)
+    drop dpy get CurrentTime XUngrabPointer drop ;
+
 x11-ui-backend ui-backend set-global
 
 [ "DISPLAY" os-env "ui.tools" "listener" ? ]