diff --git a/README.org b/README.org index 007e538..d1dd119 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. @@ -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 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) 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 () 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..6f84a2e --- /dev/null +++ b/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)) 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..122a37b --- /dev/null +++ b/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))))) 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 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))))))) 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))))