Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: a1141911e7
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 100 lines (84 sloc) 4.085 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99
;;; -*- 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)

;;; Parsing the server address

(defstruct server-address
  type
  values)

(defun server-address-value (address key)
  (cdr (find key (server-address-values address) :key #'car :test #'string=)))

(defun unescape (string)
  "String is an ASCII string with every non-ASCII (and some other)
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
                                     :element-type '(unsigned-byte 8)
                                     :fill-pointer t
                                     :adjustable t))
          (for char = (read-char in nil nil))
          (while char)
          (case char
            (#\% (let ((digit1 (digit-char-p (read-char in) 16))
                       (digit2 (digit-char-p (read-char in) 16)))
                   (assert (and digit1 digit2)
                           (digit1 digit2)
                           "Got non-digits (~A ~A) after escape char..." digit1 digit2)
                   (vector-push-extend (logior (ash digit1 4) digit2) output)))
            (t (vector-push-extend (char-code char) output)))
          (finally (return (babel:octets-to-string output :encoding :utf-8))))))

(defun parse-key-value-string (kv-string)
  "Parse a DBUS address key-value pair (foo=bar) taking care of the
strange escaping rules described in the standard. Returns a cons of
two strings."
  (iter (for part in (split "," kv-string))
        (multiple-value-bind (match? matches)
            (cl-ppcre:scan-to-strings "^([^=]+)=([^=]*)$" part)
          (unless match?
            (error "Malformed key-value pair: ~S" part))
          (collect (cons (unescape (aref matches 0))
                         (unescape (aref matches 1)))))))

(defun server-address-from-string (string)
  "Parse a single server address and return a corresponding
SERVER-ADDRES structure."
  (multiple-value-bind (match? matches)
      (cl-ppcre:scan-to-strings "^([^:]+):(.*)$" string)
    (unless match?
      (error "Malformed DBUS server address ~S" string))
    (make-server-address :type (aref matches 0)
                         :values (parse-key-value-string (aref matches 1)))))

(defun parse-server-address-list (string)
  "Parse a string as given in the environment variable
DBUS_SESSION_BUS_ADDRESS which can be a list of several server
addresses. Returns a list of SERVER-ADDRESS structures."
  (mapcar #'server-address-from-string (split ";" string)))

;;; Run-time selection of transports

(defvar *transports* nil
  "List of supported transports.")

(defun register-transport (name fn)
  (setf *transports* (cons (cons name fn)
                           (remove name *transports* :key #'car :test #'string=))))

(defmacro deftransport (name (address) &body body)
  "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
                         name
                         (symbol (string-downcase (string name)))
                         (string name))
                       (lambda (,address)
                         ,@body)))

;;; Now finally the function that wraps all of this.

(defun connect-via-address-string (string)
  "Takes a string containing a DBUS server address (or multiple) and
returns a stream to the bus."
  (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
Something went wrong with that request. Please try again.