xwin-tools/xwin-tools.lisp

;;;; xwin-tools.lisp

(in-package #:xwin)

(defvar *display* nil)

(defmacro ensure-display (&body body)
  (let ((display-sym (gensym "DISPLAY-")))
    `(let ((,display-sym nil))
       (when (null *display*)
         (setf ,display-sym (xlib:open-default-display)))
       (unwind-protect
         (let ((*display* (or *display* ,display-sym)))
           (progn
             ,@body))
         (when ,display-sym
           (xlib:close-display ,display-sym))))))

(defun root ()
  (xlib:screen-root (xlib:display-default-screen *display*)))

(defstruct winfo
  id
  desktop
  pid
  x
  y
  width
  height
  class
  machine
  title)

(defun parse-wmctrl-line (string)
  (destructuring-bind (id desktop pid x y width height class machine title) (cl-ppcre:split " +" string :limit 10)
    (make-winfo :id (parse-integer id :start 2 :radix 16)
                :desktop (parse-integer desktop)
                :pid (parse-integer pid)
                :x (parse-integer x)
                :y (parse-integer y)
                :width (parse-integer width)
                :height (parse-integer height)
                :class class
                :machine machine
                :title title)))

(defun xwin:all-windows ()
  (mapcar #'parse-wmctrl-line (uiop:run-program '("wmctrl" "-pGlx") :output :lines)))

(defun id-for-xlib (id)
  (xlib::make-window :id id :display *display*))

(defun xwin:raise (id)
  (ensure-display
    (let ((w (id-for-xlib id)))
      (xlib:set-input-focus *display* w :parent)
      (setf (xlib:window-priority w) :above))
    (xlib:display-finish-output *display*)
    id))

(defun xwin:active ()
  (first (ensure-display
           (xlib:get-property (root) :_NET_ACTIVE_WINDOW))))

(defmacro while-timeout ((timeout &optional (delay 0.1)) &body body)
  (let ((result-sym (gensym "RESULT-"))
        (delay-sym (gensym "DELAY-")))
    `(loop with ,delay-sym = ,delay
           repeat (1+ (floor ,timeout ,delay-sym))
           for ,result-sym = (progn
                               ,@body)
           if ,result-sym do (return ,result-sym) else do (sleep ,delay-sym)
           finally (return ,result-sym))))

(defun xwin:by-pid (pid &key (machine (machine-instance)) (timeout 0))
  (while-timeout (timeout)
    (loop for w in (all-windows)
          when (and (= (winfo-pid w) pid)
                    (string= (winfo-machine w) machine))
          do (return (winfo-id w))
          finally (return nil))))

(defun xwin:maximize (id)
  (ensure-display
    (xlib:send-event (root) :client-message '(:substructure-notify)
                     :window (id-for-xlib id)
                     :format 32
                     :data '(2 394 395 1)
                     :type :_NET_WM_STATE)
    (xlib:display-finish-output *display*)))

(defun xwin:all-clients ()
  (ensure-display
    (values (xlib:get-property (root) :_NET_CLIENT_LIST))))

(defun xwin:user-time (window)
  (ensure-display
    (let* ((time-window (first (xlib:get-property (id-for-xlib window)
                                                  :_NET_WM_USER_TIME_WINDOW)))
           (true-time-window (or time-window window)))
      (or (first (xlib:get-property (id-for-xlib true-time-window)
                                    :_NET_WM_USER_TIME))
          0))))

(defun xwin:clients-stacking ()
  (ensure-display
    (values (xlib:get-property (root) :_NET_CLIENT_LIST_STACKING))))

(defun xwin:pid (id)
  (ensure-display
    (first (xlib:get-property (id-for-xlib id) :_NET_WM_PID))))

(defun xwin:title (id)
  (let ((octets (ensure-display
                  (or (xlib:get-property (id-for-xlib id) :_NET_WM_NAME
                                         :result-type '(vector (unsigned-byte 8)))
                      (xlib:get-property (id-for-xlib id) :WM_NAME
                                         :result-type '(vector (unsigned-byte 8)))))))
    (if (null octets)
        ""
        (babel:octets-to-string octets :encoding :utf-8))))

(defun xwin:name (id)
  (let* ((octets (ensure-display (xlib:get-property (id-for-xlib id) :WM_CLASS
                                                    :result-type '(vector (unsigned-byte 8)))))
         (zero-pos (position 0 octets)))
    (babel:octets-to-string octets :start (1+ zero-pos) :end (1- (length octets)) :encoding :utf-8)))