Permalink
Browse files

Merge branch 'new-marshalling'

It doesn't make sense to keep the new incomplete stuff in a separate
branch of the old stuff is incomplete, too. ;)
  • Loading branch information...
2 parents 8592385 + 514cd7d commit 8b1472d23893cef841b6429cc3b6acdb28be610a @blitz committed Feb 4, 2009
Showing with 100 additions and 31 deletions.
  1. +8 −0 TODO
  2. +3 −2 cl-dbus.asd
  3. +1 −4 network.lisp
  4. +10 −9 transport.lisp
  5. +65 −0 types.lisp
  6. +13 −16 unix-transport.lisp
View
8 TODO
@@ -0,0 +1,8 @@
+-*- Mode: Outline -*-
+
+* A random list of things to do
+
+** unix-transport.lisp
+
+Port to usocket.
+
View
@@ -2,6 +2,7 @@
(defsystem cl-dbus
:components ((:file "packages")
+ (:file "types" :depends-on ("packages"))
(:file "transport" :depends-on ("packages"))
(:file "unix-transport" :depends-on ("packages" "transport"))
(:file "utilities" :depends-on ("packages"))
@@ -10,7 +11,7 @@
(:file "network" :depends-on ("packages" "cookie-sha1-auth" "anonymous-auth"
"transport"))
(:file "test" :depends-on ("packages" "network")))
- :depends-on (iterate flexi-streams defclass-star usocket cl-ppcre
- ironclad babel))
+ :depends-on (iterate flexi-streams defclass-star iolib babel cl-ppcre
+ ironclad))
;;; EOF
View
@@ -35,10 +35,7 @@ address. Defaults to :SESSION."
(write-byte 0 stream)
(force-output stream)
;; Now the ASCII authentication protocol can start.
- (let ((ascii-stream (flexi-streams:make-flexi-stream
- stream
- :external-format :ascii
- :element-type 'character)))
+ (let ((ascii-stream stream))
;; Check which authentication methods are accepted and try the
;; ones we support.
(let ((methods (accepted-methods ascii-stream)))
View
@@ -1,6 +1,6 @@
;;; -*- Mode: Lisp -*-
;;; Copyright (c) 2008 Julian Stecklina
-;;;
+;;;
;;; This file is part of CL-DBUS. Look into LICENSE for license terms.
(in-package :blitz.desktop.dbus)
@@ -19,7 +19,7 @@
chars escaped by URI-style %XX sequences, with XX being
hex-digits. Returns the unescaped string."
(with-input-from-string (in string)
- (iter (with output = (make-array 0
+ (iter (with output = (make-array 0
:element-type '(unsigned-byte 8)
:fill-pointer t
:adjustable t))
@@ -76,7 +76,7 @@ addresses. Returns a list of SERVER-ADDRESS structures."
"Register a transport for NAME. ADDRESS is the name of a
SERVER-ADDRESS structure. BODY should be code that takes the
SERVER-ADDRESS and returns a stream or NIL."
- `(register-transport ,(etypecase
+ `(register-transport ,(etypecase
name
(symbol (string-downcase (string name)))
(string name))
@@ -88,11 +88,12 @@ addresses. Returns a list of SERVER-ADDRESS structures."
(defun connect-via-address-string (string)
"Takes a string containing a DBUS server address (or multiple) and
returns a stream to the bus."
- (iter (for address in (parse-server-address-list string))
- (for transport-connector = (find (server-address-type address) *transports*
- :key #'car :test #'string=))
- (if transport-connector
- (thereis (funcall (cdr transport-connector) address))
- (warn "Unknown connection type: ~A" (server-address-type address)))))
+ (or (iter (for address in (parse-server-address-list string))
+ (for transport-connector = (find (server-address-type address) *transports*
+ :key #'car :test #'string=))
+ (if transport-connector
+ (thereis (funcall (cdr transport-connector) address))
+ (warn "Unknown connection type: ~A" (server-address-type address))))
+ (error "Unable to connect to DBUS.")))
;;; EOF
View
@@ -0,0 +1,65 @@
+;;; -*- Mode: Lisp -*-
+;;; Copyright (c) 2008 Julian Stecklina
+;;;
+;;; This file is part of CL-DBUS. Look into LICENSE for license terms.
+
+(in-package :blitz.desktop.dbus)
+
+(defclass* dbus-type ()
+ (name char alignment))
+
+(defclass* dbus-compound-type (dbus-type)
+ (element-type))
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+ (defmacro define-dbus-type (name type-char alignment &optional (superclass 'dbus-type) slots)
+ `(defclass* ,(intern (format nil "DBUS-~A" name) (find-package :blitz.desktop.dbus))
+ (,superclass)
+ ,slots
+ (:default-initargs
+ :name ',name
+ :char ',type-char
+ :alignment ,alignment))))
+
+(define-dbus-type boolean #\b 4)
+
+(define-dbus-type uint8 #\y 1)
+(define-dbus-type int16 #\n 2)
+(define-dbus-type uint16 #\q 2)
+(define-dbus-type int32 #\i 4)
+(define-dbus-type uint32 #\u 4)
+(define-dbus-type int64 #\x 8)
+(define-dbus-type uint64 #\t 8)
+(define-dbus-type double #\d 8)
+
+(define-dbus-type string #\s 4)
+(define-dbus-type signature #\g 1)
+(define-dbus-type object-path #\o 4)
+
+(define-dbus-type variant #\v 1)
+
+(define-dbus-type struct #\r 8 dbus-compound-type)
+(define-dbus-type array #\a 4 dbus-compound-type)
+(define-dbus-type dict-entry #\e 8 dbus-compound-type)
+
+(defgeneric marshall (type object vector start)
+ (:documentation "Marshalls OBJECT (interpreted as TYPE) into
+ VECTOR (starting at START). Returns VECTOR and an index pointing
+ after the written data."))
+
+(defun dbus-write-byte (vector start byte &optional (repeat 1))
+ (iter (repeat repeat)
+ (for i upfrom 0)
+ (setf (aref vector (+ start i)) byte)))
+
+(defmethod marshall :around ((type dbus-type) object vector start)
+ (let* ((alignment (alignment-of type))
+ (mod (nth-value 1 (truncate start alignment))))
+ (dbus-write-byte vector start 0 (- alignment mod))
+ (call-next-method type object vector (+ start (- alignment mod)))))
+
+(defmethod marshall ((type dbus-boolean) object vector start)
+ ;; Endianness?
+ ;; XXXX
+ )
+;;; EOF
View
@@ -1,28 +1,25 @@
;;; -*- Mode: Lisp -*-
;;; Copyright (c) 2008 Julian Stecklina
-;;;
+;;;
;;; This file is part of CL-DBUS. Look into LICENSE for license terms.
(in-package :blitz.desktop.dbus)
-;;; TODO Extend usocket to support abstract sockets and rewrite this
-;;; to use usocket.
-#+(and sbcl linux)
(deftransport unix (address)
- (handler-case
+ (handler-case
(let ((abstract (server-address-value address "abstract"))
(path (server-address-value address "path")))
- (let ((socket (make-instance (if abstract
- 'sb-bsd-sockets:local-abstract-socket
- 'sb-bsd-sockets:local-socket)
- :type :stream)))
- (sb-bsd-sockets:socket-connect socket (or abstract path))
- (sb-bsd-sockets:socket-make-stream socket
- :element-type '(unsigned-byte 8)
- :input t
- :output t)))
- (sb-bsd-sockets:socket-error (c)
- (warn "Unable to connect to dbus via unix transport, because of ~A." c)
+ (iolib.sockets:make-socket
+ :address-family :local
+ :external-format :ascii
+ :remote-filename (iolib.sockets:ensure-address
+ (or abstract path)
+ :family :local
+ :abstract (if abstract
+ t
+ nil))))
+ (t (c)
+ (warn "Unable to connect to to dbus via unix transport: ~A" c)
nil)))
;;; EOF

0 comments on commit 8b1472d

Please sign in to comment.