From ab87c7c384bd183b1af266413b47ad97f7b46a45 Mon Sep 17 00:00:00 2001 From: Mihail Ivanchev Date: Wed, 9 Apr 2025 12:29:58 +0200 Subject: [PATCH 1/7] SDL2 TTF font renderering, fist try. --- README.org | 1 + util/sdl-fonts/README.md | 34 +++++ util/sdl-fonts/package.lisp | 24 +++ util/sdl-fonts/sdl-fonts.asd | 12 ++ util/sdl-fonts/sdl-fonts.lisp | 270 ++++++++++++++++++++++++++++++++++ 5 files changed, 341 insertions(+) create mode 100644 util/sdl-fonts/README.md create mode 100644 util/sdl-fonts/package.lisp create mode 100644 util/sdl-fonts/sdl-fonts.asd create mode 100644 util/sdl-fonts/sdl-fonts.lisp diff --git a/README.org b/README.org index 0b66f4a..d06ca1d 100644 --- a/README.org +++ b/README.org @@ -129,6 +129,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 diff --git a/util/sdl-fonts/README.md b/util/sdl-fonts/README.md new file mode 100644 index 0000000..bf12636 --- /dev/null +++ b/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 +``` + +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. diff --git a/util/sdl-fonts/package.lisp b/util/sdl-fonts/package.lisp new file mode 100644 index 0000000..100d28b --- /dev/null +++ b/util/sdl-fonts/package.lisp @@ -0,0 +1,24 @@ +;;;; 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:mem-ref + cffi:inc-pointer)) diff --git a/util/sdl-fonts/sdl-fonts.asd b/util/sdl-fonts/sdl-fonts.asd new file mode 100644 index 0000000..92e3991 --- /dev/null +++ b/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 " + :license "MIT" + :depends-on (#:stumpwm #:cffi #:cffi-libffi) + :components ((:file "package") + (:file "sdl-fonts"))) + diff --git a/util/sdl-fonts/sdl-fonts.lisp b/util/sdl-fonts/sdl-fonts.lisp new file mode 100644 index 0000000..b32ba61 --- /dev/null +++ b/util/sdl-fonts/sdl-fonts.lisp @@ -0,0 +1,270 @@ +;;;; 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_WasInit" :int (flags :long)) +(defcfun "SDL_LockSurface" :void (surf :pointer)) +(defcfun "SDL_UnlockSurface" :void (surf :pointer)) +(defcfun "SDL_FreeSurface" :void (surf :pointer)) +(defcfun "TTF_Init" :int) +(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)) + (when (zerop (sdl-wasinit SDL_INIT_VIDEO)) + (sdl-init SDL_INIT_VIDEO)) + (when (zerop (ttf-wasinit)) + (ttf-init)) + (let ((font (make-instance 'font + :sdl2-ptr (ttf-openfont path size) + :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) + (ttf-sizeutf8 + (sdl2-ptr font) + text + sizes + (inc-pointer sizes (foreign-type-size :int))) + (mem-ref sizes :int 0))) + +(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))) + (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)))) From 5b17c54683fa95392b1ff18c2c5b46b6dbc809f0 Mon Sep 17 00:00:00 2001 From: szos Date: Fri, 18 Apr 2025 09:16:08 -0700 Subject: [PATCH 2/7] add frame-mode-line-mode to have a mode line per frame --- README.org | 1 + minor-mode/fml/README.md | 9 + minor-mode/fml/package.lisp | 4 + minor-mode/fml/swm-frame-mode-line.asd | 11 + minor-mode/fml/swm-frame-mode-line.lisp | 254 ++++++++++++++++++++++++ 5 files changed, 279 insertions(+) create mode 100644 minor-mode/fml/README.md create mode 100644 minor-mode/fml/package.lisp create mode 100644 minor-mode/fml/swm-frame-mode-line.asd create mode 100644 minor-mode/fml/swm-frame-mode-line.lisp diff --git a/README.org b/README.org index 0b66f4a..afe9f98 100644 --- a/README.org +++ b/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. diff --git a/minor-mode/fml/README.md b/minor-mode/fml/README.md new file mode 100644 index 0000000..913a3b5 --- /dev/null +++ b/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 + diff --git a/minor-mode/fml/package.lisp b/minor-mode/fml/package.lisp new file mode 100644 index 0000000..487a754 --- /dev/null +++ b/minor-mode/fml/package.lisp @@ -0,0 +1,4 @@ +;;;; package.lisp + +(defpackage #:swm-frame-mode-line + (:use #:cl)) diff --git a/minor-mode/fml/swm-frame-mode-line.asd b/minor-mode/fml/swm-frame-mode-line.asd new file mode 100644 index 0000000..e1f9e56 --- /dev/null +++ b/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"))) diff --git a/minor-mode/fml/swm-frame-mode-line.lisp b/minor-mode/fml/swm-frame-mode-line.lisp new file mode 100644 index 0000000..00da3e0 --- /dev/null +++ b/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) From 170622b0174f33a02c9e96f771fac9ae756c4d77 Mon Sep 17 00:00:00 2001 From: Mihail Ivanchev Date: Sat, 19 Apr 2025 13:19:07 +0200 Subject: [PATCH 3/7] Adding error handling for SDL errors. --- util/sdl-fonts/package.lisp | 1 + util/sdl-fonts/sdl-fonts.lisp | 182 ++++++++++++++++++---------------- 2 files changed, 100 insertions(+), 83 deletions(-) diff --git a/util/sdl-fonts/package.lisp b/util/sdl-fonts/package.lisp index 100d28b..6f84a2e 100644 --- a/util/sdl-fonts/package.lisp +++ b/util/sdl-fonts/package.lisp @@ -20,5 +20,6 @@ cffi:foreign-slot-value cffi:with-foreign-object cffi:foreign-type-size + cffi:null-pointer-p cffi:mem-ref cffi:inc-pointer)) diff --git a/util/sdl-fonts/sdl-fonts.lisp b/util/sdl-fonts/sdl-fonts.lisp index b32ba61..122a37b 100644 --- a/util/sdl-fonts/sdl-fonts.lisp +++ b/util/sdl-fonts/sdl-fonts.lisp @@ -54,28 +54,30 @@ (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_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)) + (ptsize :int) + (hdpi :unsigned-int) + (vdpi :unsigned-int)) (defcfun "TTF_SetFontHinting" :int (font :pointer) (hinting :int)) (defcfun "TTF_SetFontKerning" :int (font :pointer) (allowed :int)) @@ -97,20 +99,35 @@ (defun load-font (path size &key hinting (kerning t kerning-p)) (declare (type (or null hinting-mode) hinting)) - (when (zerop (sdl-wasinit SDL_INIT_VIDEO)) - (sdl-init SDL_INIT_VIDEO)) - (when (zerop (ttf-wasinit)) - (ttf-init)) - (let ((font (make-instance 'font - :sdl2-ptr (ttf-openfont path size) - :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)) + (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) @@ -189,12 +206,12 @@ (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) - (ttf-sizeutf8 - (sdl2-ptr font) - text - sizes - (inc-pointer sizes (foreign-type-size :int))) - (mem-ref sizes :int 0))) + (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 @@ -212,59 +229,58 @@ ; 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))) - (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)))) + (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))))) From 46c3ef3cf138026ffd124403541730cb312a60e0 Mon Sep 17 00:00:00 2001 From: "Kirill A. Korinsky" Date: Sun, 25 May 2025 20:56:09 +0200 Subject: [PATCH 4/7] Introduce `*swm-ssh-default-term-title-opt*` `-T` looks a universal option for `xterm` and `urxvtc`, but `sakura` requries `-t` (or `--title`) for example. --- util/swm-ssh/README.org | 8 ++++++++ util/swm-ssh/swm-ssh.lisp | 13 ++++++++++++- 2 files changed, 20 insertions(+), 1 deletion(-) diff --git a/util/swm-ssh/README.org b/util/swm-ssh/README.org index 6cf0030..ab78240 100644 --- a/util/swm-ssh/README.org +++ b/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 diff --git a/util/swm-ssh/swm-ssh.lisp b/util/swm-ssh/swm-ssh.lisp index 6b0b719..0b4f2a9 100644 --- a/util/swm-ssh/swm-ssh.lisp +++ b/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))))))) From 8851f78a2b04aee0e3f316fb54f6d94c87f97faa Mon Sep 17 00:00:00 2001 From: goose121 Date: Wed, 9 Jul 2025 15:13:34 -0600 Subject: [PATCH 5/7] Use absolute value of current_now It seems on my system that there has been a recent kernel change where `current_now` is reported negative when discharging, leading to no reported time remaining, only a dash; given this is only on certain kernel versions, it is perhaps better to just take the absolute value of `current_now` when calculating time remaining, just to remain compatible with both --- modeline/battery-portable/battery-portable.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modeline/battery-portable/battery-portable.lisp b/modeline/battery-portable/battery-portable.lisp index 56f7e29..6e84668 100644 --- a/modeline/battery-portable/battery-portable.lisp +++ b/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 () From 495d6e941e124d32fc3cf902adf87ad2300664ae Mon Sep 17 00:00:00 2001 From: eugeneandrienko Date: Sun, 27 Jul 2025 17:18:20 +0300 Subject: [PATCH 6/7] stumpish: Fix search for stumpwm PID if launched as stumpwm child process. FreeBSD specific fix. In the FreeBSD the pgrep didn't list processes, which are ancestors of pgrep even if they are matched with given string. So, if stumpish was launched from the stumpwm itself, then it couldn't find PID of stumpwm process. This fix uses pgrep with '-a' key, which enable showing even the ancestors of pgrep in the it's output. --- util/stumpish/stumpish | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/util/stumpish/stumpish b/util/stumpish/stumpish index 396be9b..afdfcc7 100755 --- a/util/stumpish/stumpish +++ b/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 From 5df5bcfd93ed19311fc0b459f3976e626189f0ff Mon Sep 17 00:00:00 2001 From: "Kirill A. Korinsky" Date: Wed, 7 Jan 2026 20:38:24 +0100 Subject: [PATCH 7/7] Tmux session manager for StumpWM This is a small module which allows to connect existed tmux session, or start a new one --- README.org | 1 + util/swm-tmux/README.org | 55 +++++++++++++++++++++++++ util/swm-tmux/package.lisp | 7 ++++ util/swm-tmux/swm-tmux.asd | 11 +++++ util/swm-tmux/swm-tmux.lisp | 80 +++++++++++++++++++++++++++++++++++++ 5 files changed, 154 insertions(+) create mode 100644 util/swm-tmux/README.org create mode 100644 util/swm-tmux/package.lisp create mode 100644 util/swm-tmux/swm-tmux.asd create mode 100644 util/swm-tmux/swm-tmux.lisp diff --git a/README.org b/README.org index 0b66f4a..af967ae 100644 --- a/README.org +++ b/README.org @@ -140,6 +140,7 @@ Advertise your module here, open a PR and include a org-mode link! - [[./util/swm-emacs/README.txt][swm-emacs]] :: A set of utilities for launching the beast. - [[./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-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 diff --git a/util/swm-tmux/README.org b/util/swm-tmux/README.org new file mode 100644 index 0000000..21f0c36 --- /dev/null +++ b/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 diff --git a/util/swm-tmux/package.lisp b/util/swm-tmux/package.lisp new file mode 100644 index 0000000..02256c1 --- /dev/null +++ b/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*)) diff --git a/util/swm-tmux/swm-tmux.asd b/util/swm-tmux/swm-tmux.asd new file mode 100644 index 0000000..fb0f3a8 --- /dev/null +++ b/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 " + :license "GPLv3" + :version "0.1" + :serial t + :depends-on ("stumpwm" "cl-ppcre") + :components ((:file "package") + (:file "swm-tmux"))) diff --git a/util/swm-tmux/swm-tmux.lisp b/util/swm-tmux/swm-tmux.lisp new file mode 100644 index 0000000..e2f0a3d --- /dev/null +++ b/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))))