Merge branch 'master' into swm-ykman

README.org

@@ -85,6 +85,7 @@ Advertise your module here, open a PR and include a org-mode link!
 - [[./media/stumpwm-mixer/README.md][stumpwm-mixer]] :: Interface to FreeBSD's built-in sound mixer
 - [[./media/stumpwm-sndioctl/README.md][stumpwm-sndioctl]] :: Interface to OpenBSD's sndioctl from StumpWM.
 ** Minor Modes
+- [[./minor-mode/fml/README.md][swm-frame-mode-line]] :: Mode line per frame
 - [[./minor-mode/grabbable-modifier-keys/README.md][grabbable-modifier-keys]] :: Allow StumpWM users to grab modifier keys and bind them
 - [[./minor-mode/mpd/README.org][mpd]] :: Displays information about the music player daemon (MPD).
 - [[./minor-mode/notifications/README.org][notifications]] :: A notification library that sends notifications to the modeline via stumpish or from stumpwm itself.
@@ -129,6 +130,7 @@ Advertise your module here, open a PR and include a org-mode link!
 - [[./util/productivity/README.org][productivity]] :: Lock StumpWM down so you have to get work done.
 - [[./util/qubes/README.org][qubes]] :: Integration to Qubes OS (https://www.qubes-os.org)
 - [[./util/screenshot/README.org][screenshot]] :: Takes screenshots and stores them as png files
+- [[./util/sdl-fonts/README.md][sdl-fonts]] :: SDL-based TTF font rendering for StumpWM.
 - [[./util/searchengines/README.org][searchengines]] :: Allows searching text using prompt or clipboard contents with various search engines
 - [[./util/shell-command-history/README.org][shell-command-history]] :: Save and load the stumpwm::*input-shell-history* to a file
 - [[./util/spatial-groups/README][spatial-groups]] :: Spatial Groups navigation for StumpWM
@@ -141,6 +143,7 @@ Advertise your module here, open a PR and include a org-mode link!
 - [[./util/swm-gaps/README.org][swm-gaps]] :: Pretty (useless) gaps for StumpWM
 - [[./util/swm-ssh/README.org][swm-ssh]] :: A simple menu selector for ssh to a remote host for stumpwm that parses your ssh config to get available hosts
 - [[./util/swm-ykman/README.org][swm-ykman]] :: Yubikey OATH TOTP manager for StumpWM
+- [[./util/swm-tmux/README.org][swm-tmux]] :: Tmux session manager for StumpWM
 - [[./util/ttf-fonts/README.txt][ttf-fonts]] :: A pure lisp implementation of TTF font rendering.
 - [[./util/undocumented/README.org][undocumented]] :: Look for stuff that should probably be in the manual that isn't
 - [[./util/urgentwindows/README.org][urgentwindows]] :: Allows focusing application windows that need user attention

minor-mode/fml/README.md

@@ -0,0 +1,9 @@
+# swm-frame-mode-line
+
+This implements a mode line per frame. Enable/disable it with the command
+`frame-mode-line-mode`
+
+## License
+
+GPLv3
+

minor-mode/fml/package.lisp

@@ -0,0 +1,4 @@
+;;;; package.lisp
+
+(defpackage #:swm-frame-mode-line
+  (:use #:cl))

minor-mode/fml/swm-frame-mode-line.asd

@@ -0,0 +1,11 @@
+;;;; swm-frame-mode-line.asd
+
+(asdf:defsystem #:swm-frame-mode-line
+  :description "Mode line per frame"
+  :author "szos at posteo dot net"
+  :license  "GPLv3"
+  :version "0.0.1"
+  :serial t
+  :depends-on (#:stumpwm)
+  :components ((:file "package")
+               (:file "swm-frame-mode-line")))

minor-mode/fml/swm-frame-mode-line.lisp

@@ -0,0 +1,254 @@
+;;;; swm-frame-mode-line.lisp
+
+(in-package #:swm-frame-mode-line)
+
+;; We need a new struct because we have to track the mode lines parent frame
+(defstruct (fml (:include stumpwm::mode-line)
+                (:constructor %make-fml))
+  frame)
+
+;; And this will be a mixin for tracking the cc, and all cc objects.
+(defclass frame-mode-line ()
+  ((fml-ml :initform nil :accessor frame-mode-line-fml)
+   (fml-cc :initform nil :accessor frame-mode-line-cc)
+   (all-cc :initform nil :accessor frame-mode-line-all-cc :allocation :class)))
+
+(defparameter *frame-mode-line-format* '("%f")
+  "The frame mode line format string/list")
+
+(stumpwm::add-screen-mode-line-formatter #\f 'format-frame-window-list)
+(defun format-frame-window-list (mode-line)
+  "Format the windowlist of a frame. This should only be called for fml objects"
+  (format nil "~{~a~^ ~}"
+          (mapcar (lambda (w)
+                    (stumpwm:format-with-on-click-id 
+                     (let ((str (stumpwm:format-expand stumpwm:*window-formatters*
+                                                       stumpwm:*window-format*
+                                                       w)))
+                       (if (eq w (stumpwm::frame-window (fml-frame mode-line)))
+                           (stumpwm::fmt-highlight str)
+                           str))
+                     :ml-on-click-focus-window
+                     (stumpwm::window-id w)))
+                  (stumpwm::sort1
+                   (stumpwm::frame-windows (stumpwm::mode-line-current-group
+                                            mode-line)
+                                           (if (typep mode-line 'fml)
+                                               (fml-frame mode-line)
+                                               (stumpwm::tile-group-current-frame
+                                                (stumpwm::mode-line-current-group
+                                                 mode-line))))
+                   #'< :key #'stumpwm::window-number))))
+
+(defun rendered-size-y-only (strings cc)
+  "Return the y height of the rendered strings"
+  (nth-value 1 (stumpwm::rendered-size strings cc)))
+
+(defun make-fml (screen frame)
+  "Create an FML mode line"
+  (let* ((window (stumpwm::make-mode-line-window screen))
+         (gc (stumpwm::make-mode-line-gc window screen))
+         (cc (stumpwm::make-mode-line-cc window screen gc))
+         (ml (%make-fml :window window
+                        :screen screen
+                        :head (stumpwm::frame-head
+                               (stumpwm::current-group)
+                               frame)
+                        :format ""
+                        :cc cc
+                        :frame frame)))
+    ml))
+
+(defun setup-fml-window (frame cc text-height)
+  "Set up the window to have the correct height"
+  (let ((win (stumpwm::ccontext-win cc))
+        (yoffset 0)
+        (xoffset 0))
+    (xlib:with-state (win)
+      (setf (xlib:drawable-height win) text-height 
+            (xlib:drawable-width win) (- (stumpwm::frame-width frame)
+                                          (* 2 xoffset)
+                                          (* 2 stumpwm::*mode-line-border-width*))
+            (xlib:window-priority win) :above
+            (xlib:drawable-y win)
+            (+ (- (stumpwm::frame-display-y (stumpwm:current-group)
+                                            frame)
+                   (rendered-size-y-only
+                    (generate-frame-windows-string
+                     (stumpwm:current-group)
+                     frame)
+                    (frame-mode-line-cc frame)))
+                yoffset)
+            (xlib:drawable-x win) (+ (stumpwm::frame-x frame) xoffset)))
+    (xlib:map-window win)
+    (xlib:display-finish-output stumpwm::*display*)))
+
+(defun display-frame-mode-line (frame &optional force)
+  "actually do the displaying of the mode line."
+  (multiple-value-bind (width height)
+      (stumpwm::rendered-size (stumpwm::mode-line-format
+                               (frame-mode-line-fml frame))
+                              (frame-mode-line-cc frame))
+    (declare (ignore width))
+    (setup-fml-window frame (frame-mode-line-cc frame) height))
+  (let* ((stumpwm::*current-mode-line-formatters*
+           stumpwm::*screen-mode-line-formatters*)
+         (stumpwm::*current-mode-line-formatter-args*
+           (list (frame-mode-line-fml frame)))
+         (str
+           (handler-case (stumpwm::mode-line-format-string
+                          (frame-mode-line-fml frame))
+             (error (c)
+               (format nil "Unable to expand mode line format string: ~S" c)))))
+    (flet ((resize-and-render (string)
+             (setf (stumpwm::mode-line-contents (frame-mode-line-fml frame))
+                   string)
+             (stumpwm::render-strings (stumpwm::mode-line-cc
+                                       (frame-mode-line-fml frame))
+                                      stumpwm::*mode-line-pad-x*
+                                      stumpwm::*mode-line-pad-y*
+                                      (stumpwm::split-string string
+                                                             (string #\Newline))
+                                      ()
+                                      :ml (frame-mode-line-fml frame))
+             (when (stumpwm::mode-line-new-bounds (frame-mode-line-fml frame))
+               (setf (stumpwm::mode-line-on-click-bounds
+                      (frame-mode-line-fml frame))
+                     (reverse (stumpwm::mode-line-new-bounds
+                               (frame-mode-line-fml frame)))))))
+      (handler-case
+          (when (or force (not (string= (stumpwm::mode-line-contents
+                                         (frame-mode-line-fml frame))
+                                        str)))
+            (resize-and-render str))
+        (error (c)
+          (resize-and-render
+           (format nil "Unable to render mode line: ~S" c)))))))
+
+(defun hide-frame-mode-line (frame)
+  (xlib:unmap-window (stumpwm::ccontext-win (frame-mode-line-cc frame))))
+
+(defmethod stumpwm::sync-frame-windows :after (group (frame frame-mode-line))
+  (display-frame-mode-line frame))
+
+(defmethod (setf stumpwm::frame-window) :after (new (frame frame-mode-line))
+  (display-frame-mode-line frame))
+
+(defmethod (setf stumpwm::window-frame) :around (frame (win stumpwm::tile-window))
+  (let ((f (ignore-errors (stumpwm::window-frame win))))
+    (call-next-method)
+    (when (typep f 'frame-mode-line)
+      (display-frame-mode-line f))))
+
+(defmethod stumpwm::frame-display-height :around (group (frame frame-mode-line))
+  (let ((h (call-next-method)))
+    (- h (rendered-size-y-only (generate-frame-windows-string
+                                (stumpwm:current-group)
+                                frame)
+                               (frame-mode-line-cc frame)))))
+
+(defmethod stumpwm::frame-display-y :around (group (frame frame-mode-line))
+  (let ((y (or (ignore-errors (call-next-method))
+               (stumpwm::frame-y frame))))
+    (+ y (rendered-size-y-only (generate-frame-windows-string
+                                (stumpwm:current-group)
+                                frame)
+                               (frame-mode-line-cc frame)))))
+
+(defun adjust-windows-for-frame (frame)
+  (when (stumpwm::frame-window frame)
+    (let* ((group (stumpwm::window-group (stumpwm::frame-window frame)))
+           (windows (stumpwm::frame-windows group frame)))
+      (mapc #'stumpwm::maximize-window windows))))
+
+(defun fml-killwins (l frame)
+  (declare (ignore l))
+  (when (typep frame 'frame-mode-line)
+    (setf (frame-mode-line-all-cc frame) (remove (frame-mode-line-cc frame)
+                                                 (frame-mode-line-all-cc frame)))
+    (xlib:unmap-window (stumpwm::ccontext-win (frame-mode-line-cc frame)))
+    (xlib:destroy-window (stumpwm::ccontext-win (frame-mode-line-cc frame)))))
+
+(stumpwm::add-hook stumpwm::*remove-split-hook* 'fml-killwins)
+
+(defun fml-focus-group (new old)
+  (declare (ignore old))
+  (when (and (stumpwm:minor-mode-enabled-p 'frame-mode-line-bar)
+             (typep new 'stumpwm::tile-group))
+    (mapc (lambda (f)
+            (display-frame-mode-line f))
+          (alexandria:flatten (stumpwm::tile-group-frame-tree new)))))
+
+(stumpwm:define-minor-mode frame-mode-line-bar
+    (frame-mode-line stumpwm:minor-mode)
+  ()
+  (:global t)
+  (:scope :frame-excluding-head)
+  (:lighter "FML")
+  (:interactive frame-mode-line-mode))
+
+(define-frame-mode-line-bar-command update-frame-mode-line (&rest rest) ()
+  "explicitly update the frame mode line"
+  (declare (ignore rest))
+  (let ((obj (stumpwm::tile-group-current-frame (stumpwm:current-group))))
+    (display-frame-mode-line obj)))
+
+(defmethod update-instance-for-different-class :after
+    (prev (obj frame-mode-line-bar) &rest rest)
+  (declare (ignore prev rest))
+  (let ((fml-ml (make-fml (stumpwm::current-screen) obj)))
+    (setf (frame-mode-line-cc obj) (stumpwm::mode-line-cc fml-ml)
+          (frame-mode-line-fml obj) fml-ml
+          (stumpwm::mode-line-format fml-ml) (list *frame-mode-line-format*)))
+  (push (frame-mode-line-cc obj) (frame-mode-line-all-cc obj))
+  (adjust-windows-for-frame obj)
+  (when (member obj (stumpwm::flatten
+                     (stumpwm::tile-group-frame-tree (stumpwm:current-group))))
+    (display-frame-mode-line obj)))
+
+(defmethod stumpwm:autodisable-minor-mode :after ((mode (eql 'frame-mode-line-bar))
+                                                  obj)
+  (adjust-windows-for-frame obj))
+
+(defmethod stumpwm:autodisable-minor-mode :before ((mode (eql 'frame-mode-line-bar))
+                                           (obj frame-mode-line-bar))
+  (setf (frame-mode-line-all-cc obj) (remove (frame-mode-line-cc obj)
+                                             (frame-mode-line-all-cc obj)))
+  (xlib:unmap-window (stumpwm::ccontext-win (frame-mode-line-cc obj)))
+  (xlib:destroy-window (stumpwm::ccontext-win (frame-mode-line-cc obj))))
+
+(defun fml-change-group (new old)
+  (when (typep old 'stumpwm::tile-group)
+    (map nil #'hide-frame-mode-line
+         (alexandria:flatten (stumpwm::tile-group-frame-tree old))))
+  (when (typep new 'stumpwm::tile-group)
+    (map nil #'display-frame-mode-line
+         (alexandria:flatten (stumpwm::tile-group-frame-tree new)))))
+
+(defun fml-setup-hook-fn (mode obj)
+  (declare (ignore mode obj))
+  (stumpwm:add-hook stumpwm:*focus-group-hook* 'fml-change-group))
+
+(stumpwm:add-hook *frame-mode-line-bar-hook* 'fml-setup-hook-fn)
+
+(defun fml-teardown-hook-fn (mode obj)
+  (declare (ignore mode obj))
+  (stumpwm:remove-hook stumpwm:*focus-group-hook* 'fml-change-group))
+
+(stumpwm:add-hook *frame-mode-line-bar-destroy-hook* 'fml-teardown-hook-fn)
+
+(defun autoadjust-windows-on-fml-disable (minor-mode object)
+  (when (eql minor-mode 'frame-mode-line-bar)
+    (adjust-windows-for-frame object)))
+
+(stumpwm:add-hook stumpwm:*minor-mode-disable-hook*
+                  'autoadjust-windows-on-fml-disable)
+
+(defun kill-all-fml-wins (mode obj)
+  (declare (ignore mode))
+  (loop for cc in (frame-mode-line-all-cc obj)
+        do (xlib:unmap-window (stumpwm::ccontext-win cc))
+           (xlib:destroy-window (stumpwm::ccontext-win cc)))
+  (setf (frame-mode-line-all-cc obj) nil))
+
+(stumpwm:add-hook *frame-mode-line-bar-destroy-hook* 'kill-all-fml-wins)

modeline/battery-portable/battery-portable.lisp

@@ -209,7 +209,7 @@
                              (sysfs-int-field path "charge_now")))
                        (consumption ()
                          (or (sysfs-int-field path "power_now")
-                             (sysfs-int-field path "current_now")))
+                             (abs (sysfs-int-field path "current_now"))))
                        (capacity-native ()
                          (sysfs-int-field path "capacity"))
                        (capacity-calculate ()

util/sdl-fonts/README.md

@@ -0,0 +1,34 @@
+A TTF renderer for StumpWM which uses SDL. SDL is actively developed by the
+whole world so the TTF code is hopefully good as well.
+
+This module requires the native packages SDL2, SDL2_ttf and libffi.
+Make sure they are installed.
+
+Load a font through by
+
+```
+(defparameter *the-font* (sdl-fonts:load-font "/usr/share/fonts/TTF/DroidSansMono.ttf" 14))
+```
+
+And use it through
+
+```
+(set-font *the-font*)
+```
+
+Of course you can also use multiple fonts. Additionally, you can specify
+the hinting and kerning by passing
+
+```
+:hinting <:normal|:light|:mono|:none|:light-subpixel>
+:kerning <boolean>
+```
+
+to `sdl-fonts:load-font`.
+
+Have fun!
+
+Use at your own risk and discretion. I assume no responsibility for any damage
+resulting from using this project. I do use it myself.
+
+This modules borrows ideas and code from clx-truetype.

util/sdl-fonts/package.lisp

@@ -0,0 +1,25 @@
+;;;; package.lisp
+
+(defpackage #:sdl-fonts
+  (:use #:cl))
+
+(in-package #:sdl-fonts)
+
+(import '(stumpwm::font-exists-p
+          stumpwm::open-font
+          stumpwm::close-font
+	  stumpwm::font-ascent
+          stumpwm::font-descent
+          stumpwm::text-line-width
+	  stumpwm::draw-image-glyphs
+          stumpwm::font-height
+          cffi:define-foreign-library
+          cffi:use-foreign-library
+          cffi:defcstruct
+          cffi:defcfun
+          cffi:foreign-slot-value
+          cffi:with-foreign-object
+          cffi:foreign-type-size
+          cffi:null-pointer-p
+          cffi:mem-ref
+          cffi:inc-pointer))

util/sdl-fonts/sdl-fonts.asd

@@ -0,0 +1,12 @@
+;;;; sdl-fonts.asd
+
+(asdf:defsystem #:sdl-fonts
+  :serial t
+  :description "SDL-based TTF font rendering for StumpWM."
+  :version "1.0.0"
+  :author "Mihail Ivanchev <contact@ivanchev.net>"
+  :license "MIT"
+  :depends-on (#:stumpwm #:cffi #:cffi-libffi)
+  :components ((:file "package")
+               (:file "sdl-fonts")))
+

util/sdl-fonts/sdl-fonts.lisp

@@ -0,0 +1,286 @@
+;;;; sdl-fonts.lisp
+
+(in-package #:sdl-fonts)
+
+(export '(load-font
+          font-exists-p
+          open-font
+          close-font
+          font-ascent
+          font-descent
+          font-height
+          text-line-width
+          draw-image-glyphs))
+
+(define-foreign-library libsdl2
+  (:unix (:or "libSDL2-2.0.so.0" "libSDL2.so.0.2" "libSDL2")))
+
+(define-foreign-library libsdl2-ttf
+  (:unix (:or "libSDL2_ttf-2.0.so.0" "libSDL2_ttf")))
+
+(use-foreign-library libsdl2)
+(use-foreign-library libsdl2-ttf)
+
+(defcstruct sdl-rect
+  (x :int)
+  (y :int)
+  (w :int)
+  (h :int))
+
+(defcstruct sdl-surface
+  (flags :uint32)
+  (format :pointer)
+  (w :int)
+  (h :int)
+  (pitch :int)
+  (pixels :pointer)
+  (userdata :pointer)
+  (locked :int)
+  (list-bitmap :pointer)
+  (clip-rect (:struct sdl-rect))
+  (map :pointer)
+  (refcount :int))
+
+(defcstruct sdl-color
+  (r :uint8)
+  (g :uint8)
+  (b :uint8)
+  (a :uint8))
+
+; Using :compile-toplevel because the var is used in a declare type statement.
+(eval-when (:compile-toplevel :load-toplevel)
+  (defvar *hinting-flags* '(:normal :light :mono :none :light-subpixel)))
+
+(deftype hinting-mode () `(member ,@*hinting-flags*))
+
+(defcfun "SDL_Init" :int (flags :long))
+(defcfun "SDL_Quit" :void)
+(defcfun "SDL_WasInit" :int (flags :long))
+(defcfun "SDL_LockSurface" :void (surf :pointer))
+(defcfun "SDL_UnlockSurface" :void (surf :pointer))
+(defcfun "SDL_FreeSurface" :void (surf :pointer))
+(defcfun "SDL_GetError" :string)
+(defcfun "TTF_Init" :int)
+(defcfun "TTF_Quit" :void)
+(defcfun "TTF_WasInit" :int)
+(defcfun "TTF_OpenFont" :pointer (file :string) (ptsize :int))
+(defcfun "TTF_SizeUTF8" :int (font :pointer)
+                             (text :string)
+                             (w :pointer)
+                             (h :pointer))
+(defcfun "TTF_RenderUTF8_Blended" :pointer (font :pointer)
+                                           (text :string)
+                                           (fg (:struct sdl-color)))
+(defcfun "TTF_FontAscent" :int (font :pointer))
+(defcfun "TTF_FontDescent" :int (font :pointer))
+(defcfun "TTF_FontHeight" :int (font :pointer))
+(defcfun "TTF_SetFontSizeDPI" :int (font :pointer)
+                                   (ptsize :int)
+                                   (hdpi :unsigned-int)
+                                   (vdpi :unsigned-int))
+(defcfun "TTF_SetFontHinting" :int (font :pointer) (hinting :int))
+(defcfun "TTF_SetFontKerning" :int (font :pointer) (allowed :int))
+
+(defclass font ()
+  ((sdl2-ptr
+     :initarg :sdl2-ptr
+     :accessor sdl2-ptr)
+   (size
+     :initarg :size
+     :accessor font-size)
+   (hdpi
+     :initform nil
+     :accessor font-hdpi)
+   (vdpi
+     :initform nil
+     :accessor font-vdpi)))
+
+(defconstant SDL_INIT_VIDEO #x00000020)
+
+(defun load-font (path size &key hinting (kerning t kerning-p))
+  (declare (type (or null hinting-mode) hinting))
+  (let ((sdl-initialized nil)
+        (ttf-initialized nil))
+    (when (zerop (sdl-wasinit SDL_INIT_VIDEO))
+      (if (zerop (sdl-init SDL_INIT_VIDEO))
+        (setf sdl-initialized t)
+        (error (sdl-geterror))))
+    (when (zerop (ttf-wasinit))
+      (if (zerop (ttf-init))
+        (setf ttf-initialized t)
+        (let ((err (sdl-geterror)))
+          (when sdl-initialized
+            (sdl-quit))
+          (error err))))
+    (let ((ptr (ttf-openfont path size)))
+      (when (null-pointer-p ptr)
+        (let ((err (sdl-geterror)))
+          (when ttf-initialized
+            (ttf-quit))
+          (when sdl-initialized
+            (sdl-quit))
+          (error err)))
+      (let ((font (make-instance 'font :sdl2-ptr ptr :size size)))
+        (when hinting
+          (ttf-setfonthinting (sdl2-ptr font)
+                              (position hinting *hinting-flags*)))
+        (when kerning-p
+          (ttf-setfontkerning (sdl2-ptr font)
+                              (if kerning 1 0)))
+        font))))
+
+(defmethod font-exists-p ((font font))
+  t)
+
+(defmethod open-font (display (font font))
+  font)
+
+(defmethod close-font ((font font))
+  t)
+
+(defmethod font-ascent ((font font))
+  (ttf-fontascent (sdl2-ptr font)))
+
+(defmethod font-descent ((font font))
+  (ttf-fontdescent (sdl2-ptr font)))
+
+(defmethod font-height ((font font))
+  (ttf-fontheight (sdl2-ptr font)))
+
+(defun get-destination-picture (drawable)
+  (or (getf (xlib:drawable-plist drawable) :ttf-surface)
+      (setf (getf (xlib:drawable-plist drawable) :ttf-surface)
+            (xlib:render-create-picture
+              drawable
+              :format (first (xlib::find-matching-picture-formats (xlib:drawable-display drawable)
+                                                                  :depth (xlib:drawable-depth drawable)))))))
+(defun get-source-pixmap (drawable)
+  (or (getf (xlib:drawable-plist drawable) :ttf-pen-surface)
+      (setf (getf (xlib:drawable-plist drawable) :ttf-pen-surface)
+            (xlib:create-pixmap
+              :drawable drawable
+              :depth (xlib:drawable-depth drawable)
+              :width 1 :height 1))))
+
+(defun get-source-picture (drawable)
+  (or (getf (xlib:drawable-plist drawable) :ttf-pen)
+      (setf (getf (xlib:drawable-plist drawable) :ttf-pen)
+            (xlib:render-create-picture
+              (get-source-pixmap drawable)
+              :format (first (xlib::find-matching-picture-formats (xlib:drawable-display drawable)
+                                                                  :depth (xlib:drawable-depth drawable)))
+              :repeat :on))))
+
+(defun display-alpha-picture-format (display)
+  (or (getf (xlib:display-plist display) :ttf-alpha-format)
+      (setf (getf (xlib:display-plist display) :ttf-alpha-format)
+            (first
+              (xlib:find-matching-picture-formats
+                display
+                :depth 8 :alpha 8 :red 0 :blue 0 :green 0)))))
+
+(defun drawable-screen (drawable)
+  (typecase drawable
+    (xlib:drawable
+      (dolist (screen (xlib:display-roots (xlib:drawable-display drawable)))
+        (when (xlib:drawable-equal (xlib:screen-root screen) (xlib:drawable-root drawable))
+          (return screen))))
+    (xlib:screen drawable)
+    (t nil)))
+
+(defun screen-default-dpi (screen)
+  "Returns default dpi for @var{screen}. pixel width * 25.4/millimeters width"
+  (values (floor (* (xlib:screen-width screen) 25.4)
+                 (xlib:screen-width-in-millimeters screen))
+          (floor (* (xlib:screen-height screen) 25.4)
+                 (xlib:screen-height-in-millimeters screen))))
+
+(defun update-dpi (font drawable)
+  (multiple-value-bind (hdpi vdpi) (screen-default-dpi (drawable-screen drawable))
+    (when (or (not (eq (font-hdpi font) hdpi))
+              (not (eq (font-vdpi font) vdpi)))
+      (ttf-setfontsizedpi (sdl2-ptr font) (font-size font) hdpi vdpi)
+      (setf (font-hdpi font) hdpi)
+      (setf (font-vdpi font) vdpi))))
+
+(defmethod text-line-width ((font font) text &rest keys &key (start 0) end translate)
+  (declare (ignorable keys start end translate))
+  (with-foreign-object (sizes :int 2)
+    (if (zerop (ttf-sizeutf8 (sdl2-ptr font)
+                             text
+                             sizes
+                             (inc-pointer sizes (foreign-type-size :int))))
+      (mem-ref sizes :int 0)
+      (error (sdl-geterror)))))
+
+(defmethod draw-image-glyphs (drawable
+                               gcontext
+                               (font font)
+                               x y
+                               text &rest keys
+                               &key (start 0) end translate width size)
+  (declare (ignorable keys start end translate width size))
+  (when (string= text "")
+    (return-from draw-image-glyphs))
+  ; Update the DPI in case it has changed (i.e. rendering to another screen).
+  (update-dpi font drawable)
+  ; This is ugly code but the idea is that we don't really know anything about
+  ; the color format etc. of the thing we are drawing on (i.e. the screen). So
+  ; we use the alpha channel of the rendered glyphs to stencil out a rectangle
+  ; in the foreground color onto a rectangle of the background color. This is
+  ; the only way to properly handle all possible cases.
+  (let ((surf (ttf-renderutf8-blended (sdl2-ptr font) text '(r 0 b 0 g 0 a 0))))
+    (when (null-pointer-p surf)
+      (error (sdl-geterror)))
+    (let* ((width (foreign-slot-value surf '(:struct sdl-surface) 'w))
+           (height (foreign-slot-value surf '(:struct sdl-surface) 'h))
+           (pitch (foreign-slot-value surf '(:struct sdl-surface) 'pitch))
+           (data (make-array (list height width) :element-type '(unsigned-byte 8))))
+      (sdl-locksurface surf)
+      (let ((pixels (foreign-slot-value surf '(:struct sdl-surface) 'pixels)))
+        (dotimes (jj height)
+          (dotimes (ii width)
+            (let ((alpha (mem-ref pixels :uint8 (+ (* jj pitch) (* ii 4) 3))))
+              (setf (aref data jj ii) alpha)))))
+      (sdl-unlocksurface surf)
+      (sdl-freesurface surf)
+      (let* ((display (xlib:drawable-display drawable))
+             (image (xlib:create-image
+                      :depth 8
+                      :width width
+                      :height height
+                      :data data))
+             (alpha-pixmap (xlib:create-pixmap :width width
+                                               :height height
+                                               :depth 8
+                                               :drawable drawable))
+             (alpha-gc (xlib:create-gcontext :drawable alpha-pixmap))
+             (alpha-pic
+               (progn
+                 (xlib:put-image alpha-pixmap alpha-gc image :x 0 :y 0)
+                 (xlib:render-create-picture alpha-pixmap
+                                             :format (display-alpha-picture-format display))))
+             (src-pic (get-source-picture drawable))
+             (dst-pic (get-destination-picture drawable)))
+        (xlib:free-gcontext alpha-gc)
+        ; Paint the source & destination surfaces in the foreground and
+        ; background colors of the context.
+        (xlib:draw-point (get-source-pixmap drawable) gcontext 0 0)
+        (let ((fg (xlib:gcontext-foreground gcontext)))
+          (setf (xlib:gcontext-foreground gcontext) (xlib:gcontext-background gcontext))
+          (xlib:draw-rectangle drawable gcontext x (- y (font-ascent font)) width height t)
+          (setf (xlib:gcontext-foreground gcontext) fg))
+        (xlib:render-composite :over
+                               src-pic
+                               alpha-pic
+                               dst-pic
+                               0
+                               0
+                               0
+                               0
+                               x
+                               (- y (font-ascent font))
+                               width
+                               height)
+        (xlib:render-free-picture alpha-pic)
+        (xlib:free-pixmap alpha-pixmap)))))

util/stumpish/stumpish

@@ -40,7 +40,9 @@ fi
 
 stumpwm_pid ()
 {
-    if command -v pgrep 2>&1 >/dev/null; then
+    if test $(uname -s) = "FreeBSD" && command -v pgrep 2>&1 > /dev/null; then
+        STUMPWM_PID=$(pgrep -a -u $(id -u) stumpwm)
+    elif command -v pgrep 2>&1 >/dev/null; then
         STUMPWM_PID=$(pgrep -u $(id -u) stumpwm)
     elif [ -d /proc ]; then
         # Go up the process chain until we locate StumpWM's process using

util/swm-ssh/README.org

@@ -31,6 +31,14 @@ Default terminal to open an ssh connection is ~urxvtc~. To change it, use
 (setq swm-ssh:*swm-ssh-default-term* "xterm")
 #+END_SRC
 
+** *swm-ssh-default-term-title-opt*
+Default terminal's title option is ~-T~ which is used to setup title to
+a connection host. It works with both ~xterm~ and ~urxvtc~ out of the
+box. ~nil~ disable it. To change it, use
+#+BEGIN_SRC lisp
+(setq swm-ssh:*swm-ssh-default-termt-itle-opt* "--title")
+#+END_SRC
+
 ** *swm-ssh-known-host-path*
 Path to thee list of know host bz SSH client. Defaults to =~/.ssh/known_hosts=.
 Change it with

util/swm-ssh/swm-ssh.lisp

@@ -3,6 +3,7 @@
 (defpackage #:swm-ssh
   (:use #:cl #:stumpwm)
   (:export #:*swm-ssh-default-term*
+           #:*swm-ssh-default-term-title-opt*
            #:*swm-ssh-known-hosts-path*)
   (:import-from #:cl-ppcre))
 
@@ -14,6 +15,8 @@
 
 (defvar *swm-ssh-default-term* "urxvtc")
 
+(defvar *swm-ssh-default-term-title-opt* "-T")
+
 (defun collect-hosts (&optional (ssh-known-hosts *swm-ssh-known-hosts-path*))
   (with-open-file (stream ssh-known-hosts :direction :input)
     (loop for line = (read-line stream nil)
@@ -32,4 +35,12 @@
     (when entry
       (let ((host (car entry)))
         (stumpwm:run-shell-command
-         (format nil "~A -T ~A -e ssh ~A" *swm-ssh-default-term* host host))))))
+         (if *swm-ssh-default-term-title-opt*
+             (format nil "~A ~A ~A -e ssh ~A"
+                     *swm-ssh-default-term*
+                     *swm-ssh-default-term-title-opt*
+                     host
+                     host)
+             (format nil "~A -e ssh ~A"
+                     *swm-ssh-default-term*
+                     host)))))))

util/swm-tmux/README.org

@@ -0,0 +1,55 @@
+* Requirements
+
+- cl-ppcre
+
+  Install cl-ppcre from the REPL:
+  #+BEGIN_SRC lisp
+  (ql:quickload :cl-ppcre)
+  #+END_SRC
+
+* Usage
+
+This module provides a menu interface for managing tmux sessions. You can
+attach to existing sessions or create new ones. Session names default to
+the current StumpWM group name.
+
+Put the following in your =~/.stumpwmrc=
+#+BEGIN_SRC lisp
+(load-module "swm-tmux")
+#+END_SRC
+
+And define a keybind in your =~/.stumpwmrc=
+#+BEGIN_SRC lisp
+(define-key *root-map* (kbd "t") "swm-tmux-session")
+#+END_SRC
+
+* Commands
+
+** swm-tmux-session
+Opens a menu to select an existing tmux session or create a new one.
+The session name defaults to the current group name.
+
+** swm-tmux-new-session
+Quickly creates a new tmux session with an auto-generated name based
+on the current group.
+
+* Variables
+
+** *swm-tmux-default-term*
+Terminal emulator to use. Default is =xterm=.
+#+BEGIN_SRC lisp
+(setf swm-tmux:*swm-tmux-default-term* "urxvtc")
+#+END_SRC
+
+** *swm-tmux-default-term-title-opt*
+Command line option for setting the terminal title. Default is =-T=.
+Set to =NIL= if your terminal does not support a title option.
+#+BEGIN_SRC lisp
+(setf swm-tmux:*swm-tmux-default-term-title-opt* "-title")
+#+END_SRC
+
+** *swm-tmux-default-term-exec-opt*
+Command line option for executing a command in the terminal. Default is =-e=.
+#+BEGIN_SRC lisp
+(setf swm-tmux:*swm-tmux-default-term-exec-opt* "-e")
+#+END_SRC

util/swm-tmux/package.lisp

@@ -0,0 +1,7 @@
+;;;; package.lisp
+
+(defpackage #:swm-tmux
+  (:use #:cl #:stumpwm)
+  (:export #:*swm-tmux-default-term*
+           #:*swm-tmux-default-term-title-opt*
+           #:*swm-tmux-default-term-exec-opt*))

util/swm-tmux/swm-tmux.asd

@@ -0,0 +1,11 @@
+;;;; swm-tmux.asd
+
+(asdf:defsystem "swm-tmux"
+  :description "Tmux session manager for StumpWM"
+  :author "Kirill A. Korinsky <kirill@korins.ky>"
+  :license "GPLv3"
+  :version "0.1"
+  :serial t
+  :depends-on ("stumpwm" "cl-ppcre")
+  :components ((:file "package")
+               (:file "swm-tmux")))

util/swm-tmux/swm-tmux.lisp

@@ -0,0 +1,80 @@
+;;;; swm-tmux.lisp
+
+(in-package #:swm-tmux)
+
+(defvar *swm-tmux-default-term* "xterm"
+  "Terminal emulator to use for tmux sessions.")
+
+(defvar *swm-tmux-default-term-title-opt* "-T"
+  "Command line option for setting terminal title. Set to NIL if your
+terminal does not support title option.")
+
+(defvar *swm-tmux-default-term-exec-opt* "-e"
+  "Command line option for executing a command in the terminal.")
+
+(defun tmux-sessions ()
+  "Return a list of existing tmux session names."
+  (let ((output (run-shell-command "tmux ls -F '#{session_name}' 2>/dev/null" t)))
+    (when (and output (not (string= output "")))
+      (cl-ppcre:split "\\n" (string-trim '(#\Newline) output)))))
+
+(defun next-session-name ()
+  "Generate next session name based on current group name.
+If group name is not already a session, use it directly.
+Otherwise append -N where N is the next available number."
+  (let* ((prefix (group-name (current-group)))
+         (sessions (tmux-sessions)))
+    (if (not (member prefix sessions :test #'string=))
+        prefix
+        (let* ((pattern (format nil "^~a-(\\d+)$" prefix))
+               (nums (loop for s in sessions
+                           for match = (cl-ppcre:scan-to-strings pattern s)
+                           when match
+                             collect (parse-integer
+                                      (aref (nth-value 1 (cl-ppcre:scan-to-strings pattern s)) 0)))))
+          (format nil "~a-~a" prefix (1+ (or (reduce #'max nums :initial-value 0) 0)))))))
+
+(defun build-term-command (session-name tmux-cmd)
+  "Build terminal command string for running tmux.
+SESSION-NAME is used for window title, TMUX-CMD is the tmux command to run."
+  (let ((title (format nil "tmux/~a" session-name)))
+    (if *swm-tmux-default-term-title-opt*
+        (format nil "~a ~a '~a' ~a ~a"
+                *swm-tmux-default-term*
+                *swm-tmux-default-term-title-opt*
+                title
+                *swm-tmux-default-term-exec-opt*
+                tmux-cmd)
+        (format nil "~a ~a ~a"
+                *swm-tmux-default-term*
+                *swm-tmux-default-term-exec-opt*
+                tmux-cmd))))
+
+(stumpwm:defcommand swm-tmux-session () ()
+  "Select an existing tmux session to attach or create a new one.
+Presents a menu with existing sessions and a [New session] option.
+Session names default to current group name."
+  (let* ((sessions (tmux-sessions))
+         (options (cons '("[New session]") (mapcar #'list sessions)))
+         (choice (select-from-menu (current-screen) options "Tmux session: ")))
+    (when choice
+      (if (string= (first choice) "[New session]")
+          ;; New session: prompt for name
+          (let ((session-name (read-one-line (current-screen)
+                                             "Session name: "
+                                             :initial-input (next-session-name))))
+            (when (and session-name (not (string= session-name "")))
+              (let ((tmux-cmd (if (member session-name sessions :test #'string=)
+                                  (format nil "tmux attach -t '~a'" session-name)
+                                  (format nil "tmux new-session -s '~a'" session-name))))
+                (run-shell-command (build-term-command session-name tmux-cmd)))))
+          ;; Existing session: attach directly
+          (let* ((session-name (first choice))
+                 (tmux-cmd (format nil "tmux attach -t '~a'" session-name)))
+            (run-shell-command (build-term-command session-name tmux-cmd)))))))
+
+(stumpwm:defcommand swm-tmux-new-session () ()
+  "Create a new tmux session with auto-generated name based on current group."
+  (let* ((session-name (next-session-name))
+         (tmux-cmd (format nil "tmux new-session -s '~a'" session-name)))
+    (run-shell-command (build-term-command session-name tmux-cmd))))