Initial commit

Author: Vincent W. Chen

.gitignore

@@ -0,0 +1,12 @@
+/target
+/lib
+/classes
+/checkouts
+pom.xml
+pom.xml.asc
+*.jar
+*.class
+.lein-deps-sum
+.lein-failures
+.lein-plugins
+.lein-repl-history

LICENSE

@@ -0,0 +1,25 @@
+The MIT License (MIT)
+
+Copyright (c) 2013 Vincent W. Chen
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+this software and associated documentation files (the "Software"), to deal in
+the Software without restriction, including without limitation the rights to
+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
+the Software, and to permit persons to whom the Software is furnished to do so,
+subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+Except as contained in this notice, the names of the authors or their
+institutions shall not be used in advertising or otherwise to promote the sale,
+use or other dealings in this Software without prior written authorization from
+the authors.

project.clj

@@ -0,0 +1,9 @@
+(defproject xcljb "0.1.0-SNAPSHOT"
+  :description "X protocol Clojure-language Binding"
+  :url "http://example.com/FIXME"
+  :license {:name "The MIT License (MIT)"
+            :url "http://opensource.org/licenses/MIT"}
+  :dependencies [[org.clojure/clojure "1.5.1"]
+                 [org.clojure/data.xml "0.0.7"]
+                 [org.slf4j/slf4j-log4j12 "1.7.5"]
+                 [gloss "0.2.2-beta4"]])

src/log4j.properties

@@ -0,0 +1,4 @@
+log4j.rootLogger=DEBUG,console
+log4j.appender.console=org.apache.log4j.ConsoleAppender
+log4j.appender.console.layout=org.apache.log4j.PatternLayout
+log4j.appender.console.layout.ConversionPattern=%d %-5p %c: %m%n

src/xcljb/auth.clj

@@ -0,0 +1,24 @@
+(ns xcljb.auth
+  (:require [xcljb.gen-common :as common]))
+
+(defn- parse-xauthority []
+  (when-let [auth-file (System/getenv "XAUTHORITY")]
+    (with-open [ins (clojure.java.io/input-stream auth-file)
+                ch (java.nio.channels.Channels/newChannel ins)]
+      (let [family (common/read-bytes ch 2)
+            addrlen (common/read-bytes ch 2)
+            addr (common/read-string ch addrlen)
+            numlen (common/read-bytes ch 2)
+            num (common/read-string ch numlen)
+            namelen (common/read-bytes ch 2)
+            name (common/read-string ch namelen)
+            datalen (common/read-bytes ch 2)
+            data (doall (repeatedly datalen #(common/read-bytes ch 1)))]
+        {:family family
+         :addr addr
+         :num num
+         :name name
+         :data data}))))
+
+(defn get-auth []
+  (parse-xauthority))

src/xcljb/conn.clj

@@ -0,0 +1,219 @@
+(ns xcljb.conn
+  (:require [clojure.tools.logging :as log]
+            [gloss.core :as gcore]
+            [gloss.io :as gio]
+            [xcljb.auth]
+            [xcljb.gen-common :as gen-common]
+            [xcljb.gen.xproto-internal :as xproto-internal]
+            [xcljb.gen.xproto-types :as xproto-types])
+  (:import [java.net InetSocketAddress]
+           [java.nio ByteOrder]
+           [java.nio.channels SocketChannel]
+           [java.util.concurrent LinkedBlockingQueue]))
+
+(def ^:private PROTOCOL-MAJOR-VERSION 11)
+(def ^:private PROTOCOL-MINOR-VERSION 0)
+
+(def ^:private BYTE-ORDER
+  (condp = (ByteOrder/nativeOrder)
+    ByteOrder/LITTLE_ENDIAN (int \l)
+    ByteOrder/BIG_ENDIAN (int \B)))
+
+(defn- parse-display-string [disp-str]
+  (let [[_ display screen] (re-matches #":(\d+).?(\d*)" disp-str)]
+    {:display (Integer/parseInt display)
+     :screen (if (empty? screen)
+               0
+               (Integer/parseInt screen))}))
+
+(defn- padding [n]
+  (rem (- 4 (rem n 4))
+       4))
+
+(defn- setup-request-codec [auth-name auth-data]
+  (let [name-len (count auth-name)
+        data-len (count auth-data)]
+    (gcore/compile-frame
+     [:ubyte :byte
+      :uint16 :uint16
+      :uint16 :uint16 :int16
+      (gcore/string :ascii :length name-len)
+      (repeat (padding name-len) :byte)
+      (repeat data-len :ubyte)
+      (repeat (padding data-len) :byte)])))
+
+(defn- make-setup-request [auth-name auth-data]
+  (let [name-len (count auth-name)
+        data-len (count auth-data)]
+    (gio/contiguous
+     (gio/encode (setup-request-codec auth-name auth-data)
+                 ;; Network byte order (big-endian), since data goes through TCP.
+                 [(int \B) 0
+                  PROTOCOL-MAJOR-VERSION PROTOCOL-MINOR-VERSION
+                  name-len data-len 0
+                  auth-name
+                  (repeat (padding name-len) 0)
+                  auth-data
+                  (repeat (padding data-len) 0)]))))
+
+(defn- handle-setup-failed-reply [ch]
+  (let [reason-len (gen-common/read-bytes ch 1)
+        protocol-major-version (gen-common/read-bytes ch 2)
+        protocol-minor-version (gen-common/read-bytes ch 2)
+        length (gen-common/read-bytes ch 2)
+        reason (gen-common/read-string ch reason-len)
+        _ (gen-common/read-pad ch (- (* length 4) reason-len))]
+    (binding [*out* *err*]
+      (println "Connection setup failed:" reason)
+      (println "Protocol version: major" protocol-major-version
+               "minor" protocol-minor-version))
+    (System/exit 1)))
+
+(defn- handle-setup-authenticate-reply [ch]
+  (let [_ (gen-common/read-pad ch 5)
+        length (gen-common/read-bytes ch 2)
+        reason (gen-common/read-string ch (* length 4))]
+    (binding [*out* *err*]
+      (println "Connection setup requires additional authentication:" reason))
+    (System/exit 2)))
+
+(defn- get-setup-success-reply [ch]
+  (let [_ (gen-common/read-pad ch 1)
+        protocol-major-version (gen-common/read-bytes ch 2)
+        protocol-minor-version (gen-common/read-bytes ch 2)
+        length (gen-common/read-bytes ch 2)
+        release-number (gen-common/read-bytes ch 4)
+        resource-id-base (gen-common/read-bytes ch 4)
+        resource-id-mask (gen-common/read-bytes ch 4)
+        motion-buffer-size (gen-common/read-bytes ch 4)
+        vendor-len (gen-common/read-bytes ch 2)
+        maximum-request-length (gen-common/read-bytes ch 2)
+        roots-len (gen-common/read-bytes ch 1)
+        pixmap-formats-len (gen-common/read-bytes ch 1)
+        image-byte-order (gen-common/read-bytes ch 1)
+        bitmap-format-bit-order (gen-common/read-bytes ch 1)
+        bitmap-format-scanline-unit (gen-common/read-bytes ch 1)
+        bitmap-format-scanline-pad (gen-common/read-bytes ch 1)
+        min-keycode (.read-type xproto-types/KEYCODE ch)
+        max-keycode (.read-type xproto-types/KEYCODE ch)
+        _ (gen-common/read-pad ch 4)
+        vendor (gen-common/read-string ch vendor-len)
+        pixmap-formats (doall (repeatedly pixmap-formats-len #(xproto-internal/read-FORMAT ch)))
+        roots (doall (repeatedly roots-len #(xproto-internal/read-SCREEN ch)))]
+    {:protocol-major-version protocol-major-version
+     :protocol-minor-version protocol-minor-version
+     :release-number release-number
+     :resource-id-base resource-id-base
+     :resource-id-mask resource-id-mask
+     :motion-buffer-size motion-buffer-size
+     :maximum-request-length maximum-request-length
+     :image-byte-order image-byte-order
+     :bitmap-format-bit-order bitmap-format-bit-order
+     :bitmap-format-scanline-unit bitmap-format-scanline-unit
+     :bitmap-format-scanline-pad bitmap-format-scanline-pad
+     :min-keycode min-keycode
+     :max-keycode max-keycode
+     :vendor vendor
+     :pixmap-formats pixmap-formats
+     :roots roots}))
+
+(defn- handle-setup-reply [ch]
+  (case (gen-common/read-bytes ch 1)
+    0 (handle-setup-failed-reply ch)
+    1 (get-setup-success-reply ch)
+    2 (handle-setup-authenticate-reply ch)))
+
+(defn- setup [ch]
+  (let [auth (xcljb.auth/get-auth)
+        req (make-setup-request (:name auth) (:data auth))]
+    (.write ch req)
+    (handle-setup-reply ch)))
+
+(defn- clear-old-replies [replyq seq-num]
+  (when-let [{seqn :seq-num, reply :reply} (.peek replyq)]
+    (when (< seqn seq-num)
+      (.take replyq)
+      (deliver reply nil)
+      (recur replyq seq-num))))
+
+(defn- deliver-reply [reply seq-num replyq]
+  (clear-old-replies replyq seq-num)
+  (let [{seqn :seq-num, opcode :opcode, r :reply, :as v} (.peek replyq)]
+    (assert v "Sequence number corresponds to no request.")
+    (assert (= seqn seq-num) "Sequence number greater than all requests.")
+    (.take replyq)
+    (deliver r reply)))
+
+(defn- get-read-reply [replyq seq-num]
+  (clear-old-replies replyq seq-num)
+  (let [{seqn :seq-num, opcode :opcode, :as r} (.peek replyq)]
+    (assert r "Sequence number corresponds to no request.")
+    (assert (= seqn seq-num) "Sequence number greater than all requests.")
+    (xproto-internal/read-reply opcode)))
+
+(defn- handle-error [ch replyq]
+  (let [code (gen-common/read-bytes ch 1)
+        seq-n (gen-common/read-bytes ch 2)
+        err ((xproto-internal/read-error code) ch)]
+    (log/error err)
+    (deliver-reply err seq-n replyq)))
+
+(defn- handle-reply [ch replyq]
+  (let [val (gen-common/read-bytes ch 1) ; FIXME: What if byte is signed?
+        seq-n (gen-common/read-bytes ch 2)
+        len (* (gen-common/read-bytes ch 4) 4)
+        read-reply (get-read-reply replyq seq-n)
+        reply (read-reply ch len val)]
+    (log/debug reply)
+    (deliver-reply reply seq-n replyq)))
+
+(defn- handle-event [ch event-num replyq eventq]
+  (let [{:keys [seq-num event]} ((xproto-internal/read-event event-num) ch)]
+    (log/debug event)
+    (when seq-num                       ; not KeymapNotify
+      (clear-old-replies replyq seq-num))
+    (.put eventq event)))
+
+(defn- read-channel [ch replyq eventq]
+  (while (.isOpen ch)
+    (try
+      (let [type-or-event (gen-common/read-bytes ch 1)]
+        (case type-or-event
+          ;; Error.
+          0 (handle-error ch replyq)
+          ;; Reply.
+          1 (handle-reply ch replyq)
+          ;; Event.
+          (handle-event ch type-or-event replyq eventq)))
+
+      (catch java.nio.channels.AsynchronousCloseException e
+        (log/debug "Channel closed.")))))
+
+(defn connect
+  ([] (connect "localhost" 6000))
+  ([host port]
+     (let [ch (SocketChannel/open (InetSocketAddress. host port))
+           ;; Disable Nagle's algorithm.
+           _ (-> ch (.socket) (.setTcpNoDelay true))
+           _ (.finishConnect ch)
+           setup-reply (future (setup ch))
+           replyq (LinkedBlockingQueue.)
+           eventq (LinkedBlockingQueue.)
+           ch-reader (Thread. #(read-channel ch replyq eventq))]
+       ;; Wait for setup-reply to finish.
+       @setup-reply
+       (.start ch-reader)
+       (atom
+        {:conn-lock (Object.)
+         :ch ch
+         :setup @setup-reply
+         :seq-num 0
+         :res-id 0
+         :replies replyq
+         :events eventq
+         :ch-reader ch-reader}))))
+
+(defn disconnect [conn]
+  (.close (:ch @conn))
+  (swap! conn (constantly nil))
+  nil)

src/xcljb/core.clj

@@ -0,0 +1,38 @@
+(ns xcljb.core)
+
+(defrecord Valueparam [masks list]
+  xcljb.gen-common/Valueparam
+  (to-mask [this]
+    (reduce bit-or 0 (:masks this)))
+  (to-list [this]
+    (let [mask-list (map vector (:masks this) (:list this))
+          sorted-mask-list (sort-by first mask-list)
+          sorted-list (map second sorted-mask-list)]
+      sorted-list)))
+
+(defn get-setup [conn]
+  (:setup @conn))
+
+(defn wait-event [conn]
+  (.take (:events @conn)))
+
+(defn poll-event [conn timeout unit]
+  (.poll (:events @conn) timeout unit))
+
+(defn- max-res-id [conn]
+  (let [res-mask (-> conn (get-setup) (:resource-id-mask))
+        res-shifts (.getLowestSetBit (BigInteger/valueOf res-mask))]
+    (assert (not (neg? res-shifts)))
+    (bit-shift-right res-mask res-shifts)))
+
+;;; TODO: Use XC-MISC extension to generate resource ids.
+(defn gen-res-id [conn]
+  (let [res-base (-> conn (get-setup) (:resource-id-base))
+        res-mask (-> conn (get-setup) (:resource-id-mask))
+        res-shifts (.getLowestSetBit (BigInteger/valueOf res-mask))
+        res-id (inc (:res-id @conn))]
+    (assert (<= res-id (max-res-id conn)) (str "Unable to generate new resource id."))
+    (swap! conn assoc :res-id res-id)
+    (assert (not (neg? res-shifts)))
+    (bit-or (bit-shift-left res-id res-shifts)
+            res-base)))

src/xcljb/examples/xcb_tutorial/README.md

@@ -0,0 +1 @@
+The examples listed here are taken from http://www.x.org/releases/X11R7.7/doc/libxcb/tutorial/index.html, translated to Clojure. The chapters and sections are listed at the start of each example, so one can compare between programming in XCB and XCLJB.

src/xcljb/examples/xcb_tutorial/create_window.clj

@@ -0,0 +1,22 @@
+;;;; 8
+
+(ns xcljb.examples.xcb-tutorial.create-window
+  (:require [xcljb.conn :as conn]
+            [xcljb.core :as core]
+            [xcljb.gen.xproto :as xproto]))
+
+(defn -main [& args]
+  (let [c (conn/connect)
+        screen (-> c (core/get-setup) (:roots) (first))
+        win (core/gen-res-id c)]
+    (xproto/create-window c
+                          (:CopyFromParent xproto/WindowClass)
+                          win
+                          (:root screen)
+                          0 0
+                          150 150
+                          10
+                          (:InputOutput xproto/WindowClass)
+                          (:root-visual screen)
+                          (core/->Valueparam [] []))
+    (xproto/map-window c win)))