From 118be5bc753af0c973057ec6472e195fe461ccba Mon Sep 17 00:00:00 2001 From: Ivy Foster Date: Wed, 30 Apr 2008 12:21:08 -0400 Subject: [PATCH] Radical code location changes. --- Makefile.in | 2 +- appearance.lisp | 346 +++++++++ color.lisp | 207 ------ command.lisp | 381 ++++++++++ core.lisp | 1048 +---------------------------- fdump.lisp | 28 +- frame.lisp | 159 +++++ group.lisp | 68 ++ handler.lisp | 500 +++++++++++++ interaction.lisp | 442 ++++++++++++ maps.lisp | 259 +++++++ menu.lisp | 134 ++++ mode-line.lisp | 4 +- netwm.lisp | 184 +++++ primitives.lisp | 52 +-- resize.lisp | 86 +++ stumpwm.asd | 15 +- time.lisp | 165 +++++ types.lisp | 165 +++++ user.lisp | 2043 ++++++++++++------------------------------------------ window.lisp | 178 +++++ 21 files changed, 3516 insertions(+), 2950 deletions(-) create mode 100644 appearance.lisp delete mode 100644 color.lisp create mode 100644 command.lisp create mode 100644 frame.lisp create mode 100644 group.lisp create mode 100644 handler.lisp create mode 100644 interaction.lisp create mode 100644 maps.lisp create mode 100644 menu.lisp create mode 100644 netwm.lisp create mode 100644 resize.lisp create mode 100644 time.lisp create mode 100644 types.lisp create mode 100644 window.lisp diff --git a/Makefile.in b/Makefile.in index 8339627..12a0973 100644 --- a/Makefile.in +++ b/Makefile.in @@ -9,7 +9,7 @@ LISP_OPTS= $(@address@hidden) # This is copied from the .asd file. It'd be nice to have the list in # one place, but oh well. -FILES=package.lisp primitives.lisp keysyms.lisp keytrans.lisp kmap.lisp input.lisp core.lisp user.lisp mode-line.lisp color.lisp stumpwm.lisp version.lisp make-image.lisp +FILES=package.lisp primitives.lisp keysyms.lisp keytrans.lisp kmap.lisp input.lisp netwm.lisp handler.lisp appearance.lisp interaction.lisp core.lisp command.lisp maps.lisp user.lisp types.lisp time.lisp fdump.lisp group.lisp window.lisp frame.lisp resize.lisp menu.lisp mode-line.lisp stumpwm.lisp version.lisp make-image.lisp all: stumpwm.info stumpwm diff --git a/appearance.lisp b/appearance.lisp new file mode 100644 index 0000000..0f9c815 --- /dev/null +++ b/appearance.lisp @@ -0,0 +1,346 @@ +;; Copyright (C) 2007 Jonathan Moore Liles +;; +;; This file is part of stumpwm. +;; +;; stumpwm is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; stumpwm is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA + +;; Commentary: +;; +;; This simplified implementation of the the C color code is as follows: +;; +;; ^B bright +;; ^b dim +;; ^n normal (sgr0) +;; +;; ^00 black black +;; ^10 red black +;; ^01 black red +;; ^1* red clear +;; +;; and so on. +;; +;; I won't explain here the many reasons that C is better than ANSI, so just +;; take my word for it. + +(in-package :stumpwm) + +(export '(*colors* + set-fg-color + set-bg-color + set-border-color + set-win-bg-color + set-focus-color + set-unfocus-color + set-msg-border-width + set-frame-outline-width + set-font + update-color-map + adjust-color + update-screen-color-context)) + +;;; Message printing functions, from core.lisp + +(defun color-exists-p (color) + (handler-case + (loop for i in *screen-list* + always (xlib:lookup-color (xlib:screen-default-colormap (screen-number i)) color)) + (xlib:name-error () nil))) + +(defun font-exists-p (font-name) + ;; if we can list the font then it exists + (plusp (length (xlib:list-font-names *display* font-name :max-fonts 1)))) + +(defmacro set-any-color (val color) + `(progn (dolist (s *screen-list*) + (setf (,val s) (alloc-color s ,color))) + (update-colors-all-screens))) + +;; FIXME: I don't like any of this. Isn't there a way to define +;; a setf method to call (update-colors-all-screens) when the user +;; does eg. (setf *foreground-color* "green") instead of having +;; these redundant set-foo functions? +(defun set-fg-color (color) + "Set the foreground color for the message bar and input +bar. @var{color} can be any color recognized by X." + (setf *text-color* color) + (set-any-color screen-fg-color color)) + +(defun set-bg-color (color) + "Set the background color for the message bar and input +bar. @var{color} can be any color recognized by X." + (set-any-color screen-bg-color color)) + +(defun set-border-color (color) + "Set the border color for the message bar and input +bar. @var{color} can be any color recognized by X." + (set-any-color screen-border-color color)) + +(defun set-win-bg-color (color) + "Set the background color of the window. The background color will only +be visible for windows with size increment hints such as @samp{emacs} +and @samp{xterm}." + (set-any-color screen-win-bg-color color)) + +(defun set-focus-color (color) + (set-any-color screen-focus-color color)) + +(defun set-unfocus-color (color) + (set-any-color screen-unfocus-color color)) + +(defun set-msg-border-width (width) + "Set the border width for the message bar and input +bar." + (check-type width (integer 0)) + (dolist (i *screen-list*) + (setf (screen-msg-border-width i) width)) + (update-border-all-screens) + t) + +(defun set-frame-outline-width (width) + (check-type width (integer 0)) + (dolist (i *screen-list*) + (setf (screen-frame-outline-width i) (if (oddp width) (1+ width) width) + (xlib:gcontext-line-width (screen-frame-outline-gc i)) (screen-frame-outline-width i))) + (update-border-all-screens) + t) + +(defun set-font (font) + "Set the font for the message bar and input bar." + (when (font-exists-p font) + (dolist (i *screen-list*) + (let ((fobj (xlib:open-font *display* (first (xlib:list-font-names *display* font :max-fonts 1))))) + (xlib:close-font (screen-font i)) + (setf (screen-font i) fobj + (xlib:gcontext-font (screen-message-gc i)) fobj) + ;; update the modelines too + (dolist (h (screen-heads i)) + (when (and (head-mode-line h) + (eq (mode-line-mode (head-mode-line h)) :stump)) + (setf (xlib:gcontext-font (mode-line-gc (head-mode-line h))) fobj) + (resize-mode-line (head-mode-line h)) + (sync-mode-line (head-mode-line h)))))) + t)) + +(defun max-width (font l) + "Return the width of the longest string in L using FONT." + (loop for i in l + maximize (xlib:text-width font i :translate #'translate-id))) + +(defun update-colors-all-screens () + "After setting the fg, bg, or border colors. call this to sync any existing windows." + (mapc 'update-colors-for-screen *screen-list*)) + +(defun update-colors-for-screen (screen) + (let ((fg (screen-fg-color screen)) + (bg (screen-bg-color screen))) + (setf (xlib:gcontext-foreground (screen-message-gc screen)) fg + (xlib:gcontext-background (screen-message-gc screen)) bg + (xlib:gcontext-foreground (screen-frame-outline-gc screen)) fg + (xlib:gcontext-background (screen-frame-outline-gc screen)) bg + (ccontext-default-fg (screen-message-cc screen)) fg + (ccontext-default-bg (screen-message-cc screen)) bg)) + (dolist (i (list (screen-message-window screen) + (screen-input-window screen))) + (setf (xlib:window-border i) (screen-border-color screen) + (xlib:window-background i) (screen-bg-color screen))) + ;; update the backgrounds of all the managed windows + (dolist (g (screen-groups screen)) + (dolist (w (group-windows g)) + (unless (eq w (group-current-window g)) + (setf (xlib:window-background (window-parent w)) (screen-win-bg-color screen)) + (xlib:clear-area (window-parent w))))) + (dolist (i (screen-withdrawn-windows screen)) + (setf (xlib:window-background (window-parent i)) (screen-win-bg-color screen)) + (xlib:clear-area (window-parent i))) + (update-screen-color-context screen)) + +(defun update-border-for-screen (screen) + (setf (xlib:drawable-border-width (screen-input-window screen)) (screen-msg-border-width screen) + (xlib:drawable-border-width (screen-message-window screen)) (screen-msg-border-width screen))) + +(defun update-border-all-screens () + "After setting the border width call this to sync any existing windows." + (mapc 'update-border-for-screen *screen-list*)) + +;;; Colors + +(defvar *colors* + '("black" + "red" + "green" + "yellow" + "blue" + "magenta" + "cyan" + "white") + "Eight colors by default. You can redefine these to whatever you like (and +then call (update-color-map)).") + +(defvar *color-map* nil) +(defvar *foreground* nil) +(defvar *background* nil) +(defvar *reverse* nil) +(defvar *color-stack* '()) + +(defun adjust-color (color amt) + (labels ((max-min (x y) (max 0 (min 1 (+ x y))))) + (setf (xlib:color-red color) (max-min (xlib:color-red color) amt) + (xlib:color-green color) (max-min (xlib:color-green color) amt) + (xlib:color-blue color) (max-min (xlib:color-blue color) amt)))) + +(defun alloc-color (screen color) + (xlib:alloc-color (xlib:screen-default-colormap (screen-number screen)) color)) + +(defun lookup-color (screen color) + (xlib:lookup-color (xlib:screen-default-colormap (screen-number screen)) color)) + +;; Normal colors are dimmed and bright colors are intensified in order +;; to more closely resemble the VGA pallet. +(defun update-color-map (screen) + (let ((scm (xlib:screen-default-colormap (screen-number screen)))) + (labels ((map-colors (amt) + (loop for c in *colors* + as color = (xlib:lookup-color scm c) + do (adjust-color color amt) + collect (xlib:alloc-color scm color)))) + (setf (screen-color-map-normal screen) (apply #'vector (map-colors -0.25)) + (screen-color-map-bright screen) (apply #'vector (map-colors 0.25)))))) + +(defun update-screen-color-context (screen) + (let* ((cc (screen-message-cc screen)) + (bright (lookup-color screen *text-color*))) + (setf + (ccontext-default-fg cc) (screen-fg-color screen) + (ccontext-default-bg cc) (screen-bg-color screen)) + (adjust-color bright 0.25) + (setf (ccontext-default-bright cc) (alloc-color screen bright)))) + +(defun get-bg-color (screen cc color) + (setf *background* color) + (if color + (svref (screen-color-map-normal screen) color) + (ccontext-default-bg cc))) + +(defun get-fg-color (screen cc color) + (setf *foreground* color) + (if color + (svref *color-map* color) + (if (eq *color-map* (screen-color-map-bright screen)) + (ccontext-default-bright cc) + (ccontext-default-fg cc)))) + +(defun set-color (screen cc s i) + (let* ((gc (ccontext-gc cc)) + (l (- (length s) i)) + (r 2) + (f (subseq s i (1+ i))) + (b (if (< l 2) "*" (subseq s (1+ i) (+ i 2))))) + (labels + ((set-fg-bg (fg bg) + (if *reverse* + (setf + (xlib:gcontext-foreground gc) bg + (xlib:gcontext-background gc) fg) + (setf + (xlib:gcontext-foreground gc) fg + (xlib:gcontext-background gc) bg))) + (update-colors () + (set-fg-bg (get-fg-color screen cc *foreground*) + (get-bg-color screen cc *background*)))) + (case (elt f 0) + (#\n ; normal + (setf f "*" b "*" r 1 + *color-map* (screen-color-map-normal screen) + *reverse* nil) + (get-fg-color screen cc nil) + (get-bg-color screen cc nil)) + (#\b ; bright off + (setf *color-map* (screen-color-map-normal screen)) + (update-colors) + (return-from set-color 1)) + (#\B ; bright on + (setf *color-map* (screen-color-map-bright screen)) + (update-colors) + (return-from set-color 1)) + (#\R + (setf *reverse* t) + (update-colors) + (return-from set-color 1)) + (#\r + (setf *reverse* nil) + (update-colors) + (return-from set-color 1)) + (#\[ + (push (list *foreground* *background* *color-map*) *color-stack*) + (return-from set-color 1)) + (#\] + (let ((colors (pop *color-stack*))) + (when colors + (setf *foreground* (first colors) + *background* (second colors) + *color-map* (third colors)))) + (update-colors) + (return-from set-color 1)) + (#\^ ; circumflex + (return-from set-color 1))) + (handler-case + (let ((fg (if (equal f "*") (progn (get-fg-color screen cc nil) (ccontext-default-fg cc)) (get-fg-color screen cc (parse-integer f)))) + (bg (if (equal b "*") (progn (get-bg-color screen cc nil) (ccontext-default-bg cc)) (get-bg-color screen cc (parse-integer b))))) + (set-fg-bg fg bg)) + (error (c) (dformat 1 "Invalid color code: ~A" c)))) r)) + +(defun render-strings (screen cc padx pady strings highlights &optional (draw t)) + (let* ((height (+ (xlib:font-descent (screen-font screen)) + (xlib:font-ascent (screen-font screen)))) + (width 0) + (gc (ccontext-gc cc)) + (win (ccontext-win cc)) + (*foreground* nil) + (*background* nil) + (*reverse* nil) + (*color-stack* '()) + (*color-map* (screen-color-map-normal screen))) + (loop for s in strings + ;; We need this so we can track the row for each element + for i from 0 to (length strings) + do (let ((x 0) (off 0)) + (loop + for st = 0 then (+ en (1+ off)) + as en = (position #\^ s :start st) + do (progn + (let ((en (if (and en (eq #\^ (elt s (1+ en)))) (1+ en) en))) + (when draw + (xlib:draw-image-glyphs win gc + (+ padx x) + (+ pady (* i height) + (xlib:font-ascent (screen-font screen))) + (subseq s st en) + :translate #'translate-id + :size 16)) + (setf x (+ x (xlib:text-width (screen-font screen) (subseq s st en) :translate #'translate-id)))) + (when en + (setf off (set-color screen cc s (1+ en)))) + (setf width (max width x))) + while en)) + when (find i highlights :test 'eql) + do (when draw (invert-rect screen win + 0 (* i height) + (xlib:drawable-width win) + height))) + (set-color screen cc "n" 0) + width)) + +;;; appearance.lisp ends here diff --git a/color.lisp b/color.lisp deleted file mode 100644 index 700ab3b..0000000 --- a/color.lisp +++ /dev/null @@ -1,207 +0,0 @@ -;; Copyright (C) 2007 Jonathan Moore Liles -;; -;; This file is part of stumpwm. -;; -;; stumpwm is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; stumpwm is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;; Boston, MA 02111-1307 USA - -;; Commentary: -;; -;; This simplified implementation of the the C color code is as follows: -;; -;; ^B bright -;; ^b dim -;; ^n normal (sgr0) -;; -;; ^00 black black -;; ^10 red black -;; ^01 black red -;; ^1* red clear -;; -;; and so on. -;; -;; I won't explain here the many reasons that C is better than ANSI, so just -;; take my word for it. - -(in-package :stumpwm) - -(export '(*colors* update-color-map adjust-color update-screen-color-context)) - -(defvar *colors* - '("black" - "red" - "green" - "yellow" - "blue" - "magenta" - "cyan" - "white") - "Eight colors by default. You can redefine these to whatever you like (and -then call (update-color-map)).") - -(defvar *color-map* nil) -(defvar *foreground* nil) -(defvar *background* nil) -(defvar *reverse* nil) -(defvar *color-stack* '()) - -(defun adjust-color (color amt) - (labels ((max-min (x y) (max 0 (min 1 (+ x y))))) - (setf (xlib:color-red color) (max-min (xlib:color-red color) amt) - (xlib:color-green color) (max-min (xlib:color-green color) amt) - (xlib:color-blue color) (max-min (xlib:color-blue color) amt)))) - -(defun alloc-color (screen color) - (xlib:alloc-color (xlib:screen-default-colormap (screen-number screen)) color)) - -(defun lookup-color (screen color) - (xlib:lookup-color (xlib:screen-default-colormap (screen-number screen)) color)) - -;; Normal colors are dimmed and bright colors are intensified in order -;; to more closely resemble the VGA pallet. -(defun update-color-map (screen) - (let ((scm (xlib:screen-default-colormap (screen-number screen)))) - (labels ((map-colors (amt) - (loop for c in *colors* - as color = (xlib:lookup-color scm c) - do (adjust-color color amt) - collect (xlib:alloc-color scm color)))) - (setf (screen-color-map-normal screen) (apply #'vector (map-colors -0.25)) - (screen-color-map-bright screen) (apply #'vector (map-colors 0.25)))))) - -(defun update-screen-color-context (screen) - (let* ((cc (screen-message-cc screen)) - (bright (lookup-color screen *text-color*))) - (setf - (ccontext-default-fg cc) (screen-fg-color screen) - (ccontext-default-bg cc) (screen-bg-color screen)) - (adjust-color bright 0.25) - (setf (ccontext-default-bright cc) (alloc-color screen bright)))) - -(defun get-bg-color (screen cc color) - (setf *background* color) - (if color - (svref (screen-color-map-normal screen) color) - (ccontext-default-bg cc))) - -(defun get-fg-color (screen cc color) - (setf *foreground* color) - (if color - (svref *color-map* color) - (if (eq *color-map* (screen-color-map-bright screen)) - (ccontext-default-bright cc) - (ccontext-default-fg cc)))) - -(defun set-color (screen cc s i) - (let* ((gc (ccontext-gc cc)) - (l (- (length s) i)) - (r 2) - (f (subseq s i (1+ i))) - (b (if (< l 2) "*" (subseq s (1+ i) (+ i 2))))) - (labels - ((set-fg-bg (fg bg) - (if *reverse* - (setf - (xlib:gcontext-foreground gc) bg - (xlib:gcontext-background gc) fg) - (setf - (xlib:gcontext-foreground gc) fg - (xlib:gcontext-background gc) bg))) - (update-colors () - (set-fg-bg (get-fg-color screen cc *foreground*) - (get-bg-color screen cc *background*)))) - (case (elt f 0) - (#\n ; normal - (setf f "*" b "*" r 1 - *color-map* (screen-color-map-normal screen) - *reverse* nil) - (get-fg-color screen cc nil) - (get-bg-color screen cc nil)) - (#\b ; bright off - (setf *color-map* (screen-color-map-normal screen)) - (update-colors) - (return-from set-color 1)) - (#\B ; bright on - (setf *color-map* (screen-color-map-bright screen)) - (update-colors) - (return-from set-color 1)) - (#\R - (setf *reverse* t) - (update-colors) - (return-from set-color 1)) - (#\r - (setf *reverse* nil) - (update-colors) - (return-from set-color 1)) - (#\[ - (push (list *foreground* *background* *color-map*) *color-stack*) - (return-from set-color 1)) - (#\] - (let ((colors (pop *color-stack*))) - (when colors - (setf *foreground* (first colors) - *background* (second colors) - *color-map* (third colors)))) - (update-colors) - (return-from set-color 1)) - (#\^ ; circumflex - (return-from set-color 1))) - (handler-case - (let ((fg (if (equal f "*") (progn (get-fg-color screen cc nil) (ccontext-default-fg cc)) (get-fg-color screen cc (parse-integer f)))) - (bg (if (equal b "*") (progn (get-bg-color screen cc nil) (ccontext-default-bg cc)) (get-bg-color screen cc (parse-integer b))))) - (set-fg-bg fg bg)) - (error (c) (dformat 1 "Invalid color code: ~A" c)))) r)) - -(defun render-strings (screen cc padx pady strings highlights &optional (draw t)) - (let* ((height (+ (xlib:font-descent (screen-font screen)) - (xlib:font-ascent (screen-font screen)))) - (width 0) - (gc (ccontext-gc cc)) - (win (ccontext-win cc)) - (*foreground* nil) - (*background* nil) - (*reverse* nil) - (*color-stack* '()) - (*color-map* (screen-color-map-normal screen))) - (loop for s in strings - ;; We need this so we can track the row for each element - for i from 0 to (length strings) - do (let ((x 0) (off 0)) - (loop - for st = 0 then (+ en (1+ off)) - as en = (position #\^ s :start st) - do (progn - (let ((en (if (and en (eq #\^ (elt s (1+ en)))) (1+ en) en))) - (when draw - (xlib:draw-image-glyphs win gc - (+ padx x) - (+ pady (* i height) - (xlib:font-ascent (screen-font screen))) - (subseq s st en) - :translate #'translate-id - :size 16)) - (setf x (+ x (xlib:text-width (screen-font screen) (subseq s st en) :translate #'translate-id)))) - (when en - (setf off (set-color screen cc s (1+ en)))) - (setf width (max width x))) - while en)) - when (find i highlights :test 'eql) - do (when draw (invert-rect screen win - 0 (* i height) - (xlib:drawable-width win) - height))) - (set-color screen cc "n" 0) - width)) - diff --git a/command.lisp b/command.lisp new file mode 100644 index 0000000..34785db --- /dev/null +++ b/command.lisp @@ -0,0 +1,381 @@ +;; Copyright (C) 2003, 2008 * +;; +;; This file is part of stumpwm. +;; +;; stumpwm is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; stumpwm is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA +;; +;; Commentary: +;; +;; (Internal and external) command infrastructure for stumpwm, from +;; user.lisp +;; +;; * user.lisp Copyright (C) 2003 Shawn Betts +;; +;; Code: + +(in-package :stumpwm) + +(export '(define-stumpwm-command + defcommand + defcommand-alias + pathname-is-executable-p + programs-in-path + run-commands + argument-line-end-p + argument-pop + argument-pop-or-read + argument-pop-rest + run-or-raise)) + +;;; Command listing/hashing + +(defstruct command-alias + from to) + +(defstruct command + name args) + +(defvar *command-hash* (make-hash-table :test 'eq) + "A list of interactive stumpwm commands.") + +(defun all-commands () + "Return a list of all interactive commands as strings." + (let (acc) + (maphash (lambda (k v) + (declare (ignore v)) + (push (string-downcase k) acc)) + *command-hash*) + (sort acc 'string<))) + +;;; defcommand and define-stumpwm-command + +(defmacro defcommand (name (&rest args) (&rest interactive-args) &body body) + "Create a command function and store its interactive hints in *command-hash*." + (check-type name symbol) + `(progn + (defun ,name ,args ,@body) + (setf (gethash ',name *command-hash*) + (make-command :name ',name + :args ',interactive-args)))) + +(defmacro define-stumpwm-command (name (&rest args) &body body) + "Deprecated. use `defcommand' instead." + (check-type name string) + (setf name (intern (string-upcase name))) + `(progn + (defun ,name ,(mapcar 'car args) ,@body) + (setf (gethash ',name *command-hash*) + (make-command :name ',name + :args ',(mapcar 'rest args))))) + +(defmacro defcommand-alias (alias original) + "Since interactive commands are functions and can conflict with +package symbols. But for backwards compatibility this macro creates an +alias name for the command that is only accessible interactively." + `(setf (gethash ',alias *command-hash*) + (make-command-alias :from ',alias + :to ',original))) + +(defun run-commands (&rest commands) + "Run each stumpwm command in sequence. This could be used if you're +used to ratpoison's rc file and you just want to run commands or don't +know lisp very well. One might put the following in one's rc file: + address@hidden +\(stumpwm:run-commands + \"escape C-z\" + \"exec firefox\" + \"split\") address@hidden example" + (loop for i in commands do + (interactive-command i))) + +;;; External commands + +(defun pathname-is-executable-p (pathname) + "Return T if the pathname describes an executable file." + #+sbcl + (let ((filename (coerce (sb-int:unix-namestring pathname) 'base-string))) + (and (eq (sb-unix:unix-file-kind filename) :file) + (sb-unix:unix-access filename sb-unix:x_ok))) + ;; FIXME: add the code for clisp + #-sbcl pathname t) + +(defun programs-in-path (base &optional full-path (path (split-string (getenv "PATH") ":"))) + "Return a list of programs in the path that start with @var{base}. if address@hidden is @var{t} then return the full path, otherwise just +return the filename. @var{path} is by default the @env{PATH} +evironment variable but can be specified. It should be a string containing +each directory seperated by a colon." + (loop + for p in path + for dir = (probe-path p) + when dir + nconc (loop + for file in (directory (merge-pathnames + (make-pathname :name :wild) dir)) + for namestring = (file-namestring file) + when (and (string= base namestring + :end1 (min (length base) + (length namestring)) + :end2 (min (length base) + (length namestring))) + (pathname-is-executable-p file)) + collect (if full-path + (namestring file) + namestring)))) + +(defun run-or-raise (cmd props &optional (all-groups *run-or-raise-all-groups*) (all-screens *run-or-raise-all-screens*)) + "Run the shell command, @var{cmd}, unless an existing window +matches @var{props}. @var{props} is a property list with the following keys: + address@hidden @code address@hidden :class +Match the window's class. address@hidden :instance +Match the window's instance or resource-name. address@hidden :role +Match the window's @code{WM_WINDOW_ROLE}. address@hidden :title +Match the window's title. address@hidden table + +By default, the global @var{*run-or-raise-all-groups*} decides whether +to search all groups or the current one for a running +instance. @var{all-groups} overrides this default. Similarily for address@hidden and @var{all-screens}." + (labels + ;; Raise the window win and select its frame. For now, it + ;; does not select the screen. + ((goto-win (win) + (let* ((group (window-group win)) + (frame (window-frame win)) + (old-frame (tile-group-current-frame group))) + (frame-raise-window group frame win) + (focus-all win) + (unless (eq frame old-frame) + (show-frame-indicator group)))) + (find-window (group) + (find-if (lambda (w) + (apply 'window-matches-properties-p w props)) + (group-windows group)))) + (let* + ((screens (if all-screens + *screen-list* + (list (current-screen)))) + (win + ;; If no qualifiers are set don't bother looking for a match. + ;; search all groups + (if all-groups + (loop named outer + for s in screens + do (loop + for g in (screen-groups s) + for win = (find-window g) + when win + do (return-from outer win))) + (find-window (current-group))))) + (if win + (goto-win win) + (run-shell-command cmd))))) + +;;; Simple command & arg parsing + +(defun split-by-one-space (string) + "Returns a list of substrings of string divided by ONE space each. +Note: Two consecutive spaces will be seen as if there were an empty +string between them." + (loop for i = 0 then (1+ j) + as j = (position #\Space string :start i) + collect (subseq string i j) + while j)) + +(defstruct argument-line + string start) + +(defvar *command-type-hash* (make-hash-table) + "A hash table of types and functions to deal with these types.") + +(defun argument-line-end-p (input) + "Return T if we're outta arguments from the input line." + (>= (argument-line-start input) + (length (argument-line-string input)))) + +(defun argument-pop (input) + "Pop the next argument off." + (unless (argument-line-end-p input) + (let* ((p1 (position-if-not (lambda (ch) + (char= ch #\Space)) + (argument-line-string input) + :start (argument-line-start input))) + (p2 (or (and p1 (position #\Space (argument-line-string input) + :start p1)) + (length (argument-line-string input))))) + (prog1 + ;; we wanna return nil if they're the same + (unless (= p1 p2) + (subseq (argument-line-string input) p1 p2)) + (setf (argument-line-start input) (1+ p2)))))) + +(defun argument-pop-or-read (input prompt &optional completions) + (or (argument-pop input) + (if completions + (completing-read (current-screen) prompt completions) + (read-one-line (current-screen) prompt)) + (throw 'error :abort))) + +(defun argument-pop-rest (input) + "Return the remainder of the argument text." + (unless (argument-line-end-p input) + (prog1 + (subseq (argument-line-string input) (argument-line-start input)) + (setf (argument-line-start input) (length + (argument-line-string input)))))) + +(defun argument-pop-rest-or-read (input prompt &optional completions) + (or (argument-pop-rest input) + (if completions + (completing-read (current-screen) prompt completions) + (read-one-line (current-screen) prompt)) + (throw 'error :abort))) + +;;; Various lookup functions + +(defun lookup-symbol (string) + ;; FIXME: should we really use string-upcase? + (let* ((ofs (split-string string ":")) + (pkg (if (> (length ofs) 1) + (find-package (string-upcase (pop ofs))) + *package*)) + (var (string-upcase (pop ofs))) + (ret (find-symbol var pkg))) + (when (plusp (length ofs)) + (throw 'error "Too many :'s")) + (if ret + (values ret pkg var) + (throw 'error (format nil "No such symbol: ~a::~a." + (package-name pkg) var))))) + +(defvar *max-command-alias-depth* 10 + "") + +(defun get-command-symbol (command) + (if (stringp command) + (find-symbol (string-upcase command) :stumpwm) + command)) + +(defun get-command-structure (command) + "Return the command structure for COMMAND." + (declare (type (or string symbol) command)) + (setf command (get-command-symbol command)) + (and command + (loop for c = (gethash command *command-hash*) + for depth from 1 + until (or (null c) + (command-p c)) + ;; the only other possibility is an alias + do (setf command (command-alias-to c)) + (when (> depth *max-command-alias-depth*) + (error "Maximum command alias depth exceded")) + finally (return c)))) + +;;; Interaction + +(defun call-interactively (command &optional (input "")) + "Parse the command's arguments from inputgiven the command's +argument specifications then execute it. Returns a string or nil if +user aborted." + (declare (type (or string symbol) command) + (type (or string argument-line) input)) + ;; Catch parse errors + (catch 'error + (let* ((arg-line (if (stringp input) + (make-argument-line :string input + :start 0) + input)) + (cmd-data (or + (get-command-structure command) + (throw + 'error + (format nil "Command '~a' not found." command)))) + (arg-specs (command-args cmd-data)) + (args (loop for spec in arg-specs + collect (let* ((type (if (listp spec) + (first spec) + spec)) + (prompt (when (listp spec) + (second spec))) + (fn (gethash type *command-type-hash*))) + (unless fn + (throw + 'error + (format nil "Bad argument type: ~s" type))) + ;; If the prompt is NIL then it's + ;; considered an optional argument and + ;; we shouldn't prompt for it if the + ;; arg line is empty. + (if (and (null prompt) + (argument-line-end-p arg-line)) + (loop-finish) + ;; FIXME: Is it presumptuous to assume NIL means abort? + (or (funcall fn arg-line prompt) + (throw 'error :abort))))))) + ;; Did the whole string get parsed? + (unless (or (argument-line-end-p arg-line) + (position-if 'alphanumericp + (argument-line-string arg-line) + :start (argument-line-start arg-line))) + (throw 'error (format nil "Trailing garbage: ~{~A~^ ~}" + (subseq (argument-line-string arg-line) + (argument-line-start arg-line))))) + ;; Success + (prog1 + (apply (command-name cmd-data) args) + (setf *last-command* command))))) + +(defun interactive-command (cmd) + "exec cmd and echo the result." + (labels ((parse-and-run-command (input) + (let* ((arg-line (make-argument-line :string input + :start 0)) + (cmd (argument-pop arg-line))) + (call-interactively cmd arg-line)))) + (multiple-value-bind (result error-p) + ;; this fancy footwork lets us grab the backtrace from where the + ;; error actually happened. + (restart-case + (handler-bind + ((error (lambda (c) + (invoke-restart + 'interactive-command-error + (format nil + "^B^1*Error In Command '^b~a^B': ^n~A~a" + cmd c (if *show-command-backtrace* + (backtrace-string) "")))))) + (parse-and-run-command cmd)) + (interactive-command-error (err-text) + (values err-text t))) + ;; interactive commands update the modeline + (update-all-mode-lines) + (cond ((stringp result) + (if error-p + (message-no-timeout "~a" result) + (message "~a" result))) + ((eq result :abort) + (unless *suppress-abort-messages* + (message "Abort."))))))) + +;;; command.lisp ends here diff --git a/core.lisp b/core.lisp index 240e2ab..3118bf9 100644 --- a/core.lisp +++ b/core.lisp @@ -26,41 +26,19 @@ (in-package :stumpwm) -(export '(*top-map* - current-group +(export '(current-group current-screen current-srceen current-window def-window-attr - echo-string - err - get-x-selection - message save-frame-excursion screen-current-window set-normal-gravity set-maxsize-gravity set-transient-gravity set-window-geometry - set-fg-color - set-bg-color - set-border-color - set-win-bg-color - set-focus-color - set-unfocus-color - set-msg-border-width - set-frame-outline-width - set-font - set-x-selection window-send-string)) -;; Do it this way so its easier to wipe the map and get a clean one. -(when (null *top-map*) - (setf *top-map* - (let ((m (make-sparse-keymap))) - (define-key m (kbd "C-t") '*root-map*) - m))) - ;; Wow, is there an easier way to do this? (defmacro def-thing-attr-macro (thing hash-slot) (let ((attr (gensym "ATTR")) @@ -176,12 +154,6 @@ start at -1 and go down." (< (group-number g) 1)) groups)) -(defun netwm-group-id (group) - "netwm specifies that desktop/group numbers are contiguous and start -at 0. Return a netwm compliant group id." - (let ((screen (group-screen group))) - (position group (sort-groups screen)))) - (defun switch-to-group (new-group) (let* ((screen (group-screen new-group)) (old-group (screen-current-group screen))) @@ -267,17 +239,6 @@ at 0. Return a netwm compliant group id." (dolist (window (group-windows from-group)) (move-window-to-group window to-group))) -(defun netwm-update-groups (screen) - "update all windows to reflect a change in the group list." - ;; FIXME: This could be optimized only to update windows when there - ;; is a need. - (loop for i from 0 - for group in (sort-groups screen) - do (dolist (w (group-windows group)) - (xlib:change-property (window-xwin w) :_NET_WM_DESKTOP - (list i) - :cardinal 32)))) - (defun kill-group (group to-group) (when (> (length (screen-groups (group-screen group))) 1) (let ((screen (group-screen group))) @@ -285,29 +246,6 @@ at 0. Return a netwm compliant group id." (setf (screen-groups screen) (remove group (screen-groups screen))) (netwm-update-groups screen)))) -(defun netwm-set-group-properties (screen) - "Set NETWM properties regarding groups of SCREEN. -Groups are known as \"virtual desktops\" in the NETWM standard." - (let ((root (screen-root screen))) - ;; _NET_NUMBER_OF_DESKTOPS - (xlib:change-property root :_NET_NUMBER_OF_DESKTOPS - (list (length (screen-groups screen))) - :cardinal 32) - (unless *initializing* - ;; _NET_CURRENT_DESKTOP - (xlib:change-property root :_NET_CURRENT_DESKTOP - (list (netwm-group-id (screen-current-group screen))) - :cardinal 32)) - ;; _NET_DESKTOP_NAMES - (xlib:change-property root :_NET_DESKTOP_NAMES - (let ((names (mapcan - (lambda (group) - (list (string-to-utf8 (group-name group)) - '(0))) - (sort-groups screen)))) - (apply #'concatenate 'list names)) - :UTF8_STRING 8))) - (defun add-group (screen name) "Create a new group in SCREEN with the supplied name. group names starting with a . are considered hidden groups. Hidden groups are @@ -340,7 +278,6 @@ Groups are known as \"virtual desktops\" in the NETWM standard." ;;; Window functions - ;; Since StumpWM already uses the term 'group' to refer to Virtual Desktops, ;; we'll call the grouped windows of an application a 'gang' @@ -515,17 +452,6 @@ Groups are known as \"virtual desktops\" in the NETWM standard." ;; 0 0 300 200 t) ;; (xlib:clear-area (window-parent window))))) -(defun xwin-net-wm-name (win) - "Return the netwm wm name" - (let ((name (xlib:get-property win :_NET_WM_NAME))) - (when name - (utf8-to-string name)))) - -(defun xwin-name (win) - (or - (xwin-net-wm-name win) - (xlib:wm-name win))) - ;; FIXME: should we raise the winodw or its parent? (defun raise-window (win) "Map the window if needed and bring it to the top of the stack. Does not affect focus." @@ -1160,9 +1086,6 @@ than the root window's width and height." (place-existing-window screen xwin) (place-window screen xwin)))) -(defun netwm-remove-window (window) - (xlib:delete-property (window-xwin window) :_NET_WM_DESKTOP)) - (defun process-mapped-window (screen xwin) "Add the window to the screen's mapped window list and process it as needed." @@ -1336,94 +1259,6 @@ maximized, and given focus." (xlib:kill-client *display* (xlib:window-id window))) -;;; Message printing functions - -(defun color-exists-p (color) - (handler-case - (loop for i in *screen-list* - always (xlib:lookup-color (xlib:screen-default-colormap (screen-number i)) color)) - (xlib:name-error () nil))) - -(defun font-exists-p (font-name) - ;; if we can list the font then it exists - (plusp (length (xlib:list-font-names *display* font-name :max-fonts 1)))) - -(defmacro set-any-color (val color) - `(progn (dolist (s *screen-list*) - (setf (,val s) (alloc-color s ,color))) - (update-colors-all-screens))) - -;; FIXME: I don't like any of this. Isn't there a way to define -;; a setf method to call (update-colors-all-screens) when the user -;; does eg. (setf *foreground-color* "green") instead of having -;; these redundant set-foo functions? -(defun set-fg-color (color) - "Set the foreground color for the message bar and input -bar. @var{color} can be any color recognized by X." - (setf *text-color* color) - (set-any-color screen-fg-color color)) - -(defun set-bg-color (color) - "Set the background color for the message bar and input -bar. @var{color} can be any color recognized by X." - (set-any-color screen-bg-color color)) - -(defun set-border-color (color) - "Set the border color for the message bar and input -bar. @var{color} can be any color recognized by X." - (set-any-color screen-border-color color)) - -(defun set-win-bg-color (color) - "Set the background color of the window. The background color will only -be visible for windows with size increment hints such as @samp{emacs} -and @samp{xterm}." - (set-any-color screen-win-bg-color color)) - -(defun set-focus-color (color) - (set-any-color screen-focus-color color)) - -(defun set-unfocus-color (color) - (set-any-color screen-unfocus-color color)) - -(defun set-msg-border-width (width) - "Set the border width for the message bar and input -bar." - (check-type width (integer 0)) - (dolist (i *screen-list*) - (setf (screen-msg-border-width i) width)) - (update-border-all-screens) - t) - -(defun set-frame-outline-width (width) - (check-type width (integer 0)) - (dolist (i *screen-list*) - (setf (screen-frame-outline-width i) (if (oddp width) (1+ width) width) - (xlib:gcontext-line-width (screen-frame-outline-gc i)) (screen-frame-outline-width i))) - (update-border-all-screens) - t) - -(defun set-font (font) - "Set the font for the message bar and input bar." - (when (font-exists-p font) - (dolist (i *screen-list*) - (let ((fobj (xlib:open-font *display* (first (xlib:list-font-names *display* font :max-fonts 1))))) - (xlib:close-font (screen-font i)) - (setf (screen-font i) fobj - (xlib:gcontext-font (screen-message-gc i)) fobj) - ;; update the modelines too - (dolist (h (screen-heads i)) - (when (and (head-mode-line h) - (eq (mode-line-mode (head-mode-line h)) :stump)) - (setf (xlib:gcontext-font (mode-line-gc (head-mode-line h))) fobj) - (resize-mode-line (head-mode-line h)) - (sync-mode-line (head-mode-line h)))))) - t)) - -(defun max-width (font l) - "Return the width of the longest string in L using FONT." - (loop for i in l - maximize (xlib:text-width font i :translate #'translate-id))) - (defun get-gravity-coords (gravity width height minx miny maxx maxy) "Return the x y coords for a window on with gravity etc" (values (case gravity @@ -1454,34 +1289,6 @@ function expects to be wrapped in a with-state for win." (setf (xlib:drawable-y win) (max (head-y (current-head)) (+ (head-y (current-head)) y)) (xlib:drawable-x win) (max (head-x (current-head)) (+ (head-x (current-head)) x))))))) -(defun setup-message-window (screen lines width) - (let ((height (* lines - (+ (xlib:font-ascent (screen-font screen)) - (xlib:font-descent (screen-font screen))))) - (win (screen-message-window screen))) - ;; Now that we know the dimensions, raise and resize it. - (xlib:with-state (win) - (setf (xlib:drawable-height win) height - (xlib:drawable-width win) (+ width (* *message-window-padding* 2)) - (xlib:window-priority win) :above) - (setup-win-gravity screen win *message-window-gravity*)) - (xlib:map-window win) - ;; Clear the window - (xlib:clear-area win) - (incf (screen-ignore-msg-expose screen)) - ;; Have to flush this or the window might get cleared - ;; after we've already started drawing it. - (xlib:display-finish-output *display*))) - -(defun invert-rect (screen win x y width height) - "invert the color in the rectangular area. Used for highlighting text." - (let ((gcontext (xlib:create-gcontext :drawable win - :foreground (screen-fg-color screen) - :function boole-xor))) - (xlib:draw-rectangle win gcontext x y width height t) - (setf (xlib:gcontext-foreground gcontext) (screen-bg-color screen)) - (xlib:draw-rectangle win gcontext x y width height t))) - ;;; Frame functions @@ -2084,26 +1891,6 @@ windows used to draw the numbers in. The caller must destroy them." ;;; Screen functions -(defun netwm-update-client-list-stacking (screen) - (unless *initializing* - (xlib:change-property (screen-root screen) - :_NET_CLIENT_LIST_STACKING - ;; Order is bottom to top. - (reverse (mapcar 'window-xwin (all-windows))) - :window 32 - :transform #'xlib:drawable-id - :mode :replace))) - -(defun netwm-update-client-list (screen) - (xlib:change-property (screen-root screen) - :_NET_CLIENT_LIST - (screen-mapped-windows screen) - :window 32 - :transform #'xlib:drawable-id - :mode :replace) - (netwm-update-client-list-stacking screen)) - - (defun screen-add-mapped-window (screen xwin) (push xwin (screen-mapped-windows screen)) (netwm-update-client-list screen)) @@ -2183,60 +1970,6 @@ windows used to draw the numbers in. The caller must destroy them." (defun screen-root (screen) (xlib:screen-root (screen-number screen))) -(defun update-colors-for-screen (screen) - (let ((fg (screen-fg-color screen)) - (bg (screen-bg-color screen))) - (setf (xlib:gcontext-foreground (screen-message-gc screen)) fg - (xlib:gcontext-background (screen-message-gc screen)) bg - (xlib:gcontext-foreground (screen-frame-outline-gc screen)) fg - (xlib:gcontext-background (screen-frame-outline-gc screen)) bg - (ccontext-default-fg (screen-message-cc screen)) fg - (ccontext-default-bg (screen-message-cc screen)) bg)) - (dolist (i (list (screen-message-window screen) - (screen-input-window screen))) - (setf (xlib:window-border i) (screen-border-color screen) - (xlib:window-background i) (screen-bg-color screen))) - ;; update the backgrounds of all the managed windows - (dolist (g (screen-groups screen)) - (dolist (w (group-windows g)) - (unless (eq w (group-current-window g)) - (setf (xlib:window-background (window-parent w)) (screen-win-bg-color screen)) - (xlib:clear-area (window-parent w))))) - (dolist (i (screen-withdrawn-windows screen)) - (setf (xlib:window-background (window-parent i)) (screen-win-bg-color screen)) - (xlib:clear-area (window-parent i))) - (update-screen-color-context screen)) - -(defun update-colors-all-screens () - "After setting the fg, bg, or border colors. call this to sync any existing windows." - (mapc 'update-colors-for-screen *screen-list*)) - -(defun update-border-for-screen (screen) - (setf (xlib:drawable-border-width (screen-input-window screen)) (screen-msg-border-width screen) - (xlib:drawable-border-width (screen-message-window screen)) (screen-msg-border-width screen))) - -(defun update-border-all-screens () - "After setting the border width call this to sync any existing windows." - (mapc 'update-border-for-screen *screen-list*)) - -(defun internal-window-p (screen win) - "Return t if win is a window used by stumpwm" - (or (xlib:window-equal (screen-message-window screen) win) - (xlib:window-equal (screen-input-window screen) win) - (xlib:window-equal (screen-focus-window screen) win) - (xlib:window-equal (screen-key-window screen) win))) - -(defun unmap-message-window (screen) - "Unmap the screen's message window, if it is mapped." - (unless (eq (xlib:window-map-state (screen-message-window screen)) :unmapped) - (xlib:unmap-window (screen-message-window screen)))) - -(defun unmap-all-message-windows () - (mapc #'unmap-message-window *screen-list*) - (when (timer-p *message-window-timer*) - (cancel-timer *message-window-timer*) - (setf *message-window-timer* nil))) - (defun unmap-frame-indicator-window (screen) "Unmap the screen's message window, if it is mapped." ;; (unless (eq (xlib:window-map-state (screen-frame-window screen)) :unmapped) @@ -2301,85 +2034,6 @@ windows used to draw the numbers in. The caller must destroy them." (echo-in-window w font (screen-fg-color (current-screen)) (screen-bg-color (current-screen)) string) (reset-frame-indicator-timer))))) -(defun echo-in-window (win font fg bg string) - (let* ((height (font-height font)) - (gcontext (xlib:create-gcontext :drawable win - :font font - :foreground fg - :background bg)) - (width (xlib:text-width font string))) - (xlib:with-state (win) - (setf (xlib:drawable-height win) height - (xlib:drawable-width win) width)) - (xlib:clear-area win) - (xlib:display-finish-output *display*) - (xlib:draw-image-glyphs win gcontext 0 (xlib:font-ascent font) string))) - -(defun push-last-message (screen strings highlights) - ;; only push unique messages - (unless *record-last-msg-override* - (push strings (screen-last-msg screen)) - (push highlights (screen-last-msg-highlights screen)) - ;; crop for size - (when (>= (length (screen-last-msg screen)) *max-last-message-size*) - (setf (screen-last-msg screen) (butlast (screen-last-msg screen))) - (setf (screen-last-msg-highlights screen) (butlast (screen-last-msg-highlights screen)))))) - -(defun redraw-current-message (screen) - (let ((*record-last-msg-override* t) - (*ignore-echo-timeout* t)) - (dformat 5 "Redrawing message window!~%") - (apply 'echo-string-list screen (screen-current-msg screen) (screen-current-msg-highlights screen)))) - -(defun echo-nth-last-message (screen n) - (let ((*record-last-msg-override* t)) - (apply 'echo-string-list screen (nth n (screen-last-msg screen)) (nth n (screen-last-msg-highlights screen))))) - -(defun echo-string-list (screen strings &rest highlights) - "Draw each string in l in the screen's message window. HIGHLIGHT is - the nth entry to highlight." - (unless *executing-stumpwm-command* - (let ((width (render-strings screen (screen-message-cc screen) *message-window-padding* 0 strings '() nil))) - (setup-message-window screen (length strings) width) - (render-strings screen (screen-message-cc screen) *message-window-padding* 0 strings highlights)) - (setf (screen-current-msg screen) - strings - (screen-current-msg-highlights screen) - highlights)) - (push-last-message screen strings highlights) - (xlib:display-finish-output *display*) - ;; Set a timer to hide the message after a number of seconds - (if *suppress-echo-timeout* - ;; any left over timers need to be canceled. - (when (timer-p *message-window-timer*) - (cancel-timer *message-window-timer*) - (setf *message-window-timer* nil)) - (reset-message-window-timer)) - (apply 'run-hook-with-args *message-hook* strings)) - -(defun echo-string (screen msg) - "Display @var{string} in the message bar on @var{screen}. You almost always want to use @command{message}." - (echo-string-list screen (split-string msg (string #\Newline)))) - -(defun message (fmt &rest args) - "run FMT and ARGS through `format' and echo the result to the current screen." - (echo-string (current-screen) (apply 'format nil fmt args))) - - -(defun err (fmt &rest args) - "run FMT and ARGS through format and echo the result to the -current screen along with a backtrace. For careful study, the -message does not time out." - (let ((*suppress-echo-timeout* t)) - (echo-string (current-screen) - (concat (apply 'format nil fmt args) - (backtrace-string))))) - -(defun message-no-timeout (fmt &rest args) - "Like message, but the window doesn't disappear after a few seconds." - (let ((*suppress-echo-timeout* t)) - (apply 'message fmt args))) - (defmacro with-current-screen (screen &body body) "A macro to help us out with early set up." `(let ((*screen-list* (list ,screen))) @@ -2389,47 +2043,6 @@ message does not time out." "Return the current screen." (car *screen-list*)) -(defun netwm-set-properties (screen focus-window) - "Set NETWM properties on the root window of the specified screen. -FOCUS-WINDOW is an extra window used for _NET_SUPPORTING_WM_CHECK." - (let* ((screen-number (screen-number screen)) - (root (xlib:screen-root screen-number))) - ;; _NET_SUPPORTED - (xlib:change-property root :_NET_SUPPORTED - (mapcar (lambda (a) - (xlib:intern-atom *display* a)) - (append +netwm-supported+ - (mapcar #'car +netwm-window-types+))) - :atom 32) - - ;; _NET_SUPPORTING_WM_CHECK - (xlib:change-property root :_NET_SUPPORTING_WM_CHECK - (list focus-window) :window 32 - :transform #'xlib:drawable-id) - (xlib:change-property focus-window :_NET_SUPPORTING_WM_CHECK - (list focus-window) :window 32 - :transform #'xlib:drawable-id) - (xlib:change-property focus-window :_NET_WM_NAME - "stumpwm" - :string 8 :transform #'xlib:char->card8) - - ;; _NET_CLIENT_LIST - (xlib:change-property root :_NET_CLIENT_LIST - () :window 32 - :transform #'xlib:drawable-id) - - ;; _NET_DESKTOP_GEOMETRY - (xlib:change-property root :_NET_DESKTOP_GEOMETRY - (list (xlib:screen-width screen-number) - (xlib:screen-height screen-number)) - :cardinal 32) - - ;; _NET_DESKTOP_VIEWPORT - (xlib:change-property root :_NET_DESKTOP_VIEWPORT - (list 0 0) :cardinal 32) - - (netwm-set-group-properties screen))) - (defun init-screen (screen-number id host) "Given a screen number, returns a screen structure with initialized members" ;; Listen for the window manager events on the root window @@ -2662,148 +2275,6 @@ FOCUS-WINDOW is an extra window used for _NET_SUPPORTING_WM_CHECK." (head-height oh) (head-height nh))) -;;; keyboard helper functions - -(defun key-to-keycode+state (key) - (let ((code (xlib:keysym->keycodes *display* (key-keysym key)))) - (cond ((eq (xlib:keycode->keysym *display* code 0) (key-keysym key)) - (values code (x11-mods key))) - ((eq (xlib:keycode->keysym *display* code 1) (key-keysym key)) - (values code (apply 'xlib:make-state-mask - (cons :shift (xlib:make-state-keys (x11-mods key)))))) - (t - ;; just warn them and go ahead as scheduled - (warn "Don't know how to encode ~s" key) - (values code (x11-mods key)))))) - -(defun send-fake-key (win key) - "Send a fake key event to win. ch is the character and mods is a -list of modifier symbols." - (multiple-value-bind (code state) (key-to-keycode+state key) - (xlib:send-event (window-xwin win) :key-press (xlib:make-event-mask :key-press) - :display *display* - :root (screen-root (window-screen win)) - ;; Apparently we need these in here, though they - ;; make no sense for a key event. - :x 0 :y 0 :root-x 0 :root-y 0 - :window (window-xwin win) :event-window (window-xwin win) - :code code - :state state))) - -(defun send-fake-click (win button) - "Send a fake key event to win. ch is the character and mods is a -list of modifier symbols." - ;; I don't know why this doesn't work. Sadly CLX doesn't have the - ;; XTest extension like xlib does. With it this would be 2 lines. - (multiple-value-bind (x y) (xlib:query-pointer (window-xwin win)) - (multiple-value-bind (rx ry) (xlib:query-pointer (screen-root (window-screen win))) - (xlib:send-event (window-xwin win) :button-press (xlib:make-event-mask :button-press) - :display *display* - :root (screen-root (window-screen win)) - :window (window-xwin win) :event-window (window-xwin win) - :code button - :state 0 - :x x :y y :root-x rx :root-y ry - :same-screen-p t) - (xlib:send-event (window-xwin win) :button-release (xlib:make-event-mask :button-release) - :display *display* - :root (screen-root (window-screen win)) - :window (window-xwin win) :event-window (window-xwin win) - :code button - :state #x100 - :x x :y y :root-x rx :root-y ry - :same-screen-p t)))) - - -;;; Pointer helper functions - -(defun grab-pointer (screen) - "Grab the pointer and set the pointer shape." - (let* ((white (xlib:make-color :red 1.0 :green 1.0 :blue 1.0)) - (black (xlib:make-color :red 0.0 :green 0.0 :blue 0.0)) - (cursor-font (xlib:open-font *display* "cursor")) - (cursor (xlib:create-glyph-cursor :source-font cursor-font - :source-char 64 - :mask-font cursor-font - :mask-char 65 - :foreground black - :background white))) - (xlib:grab-pointer (screen-root screen) nil :owner-p nil - :cursor cursor))) - -(defun ungrab-pointer () - "Remove the grab on the cursor and restore the cursor shape." - (xlib:ungrab-pointer *display*) - (xlib:display-finish-output *display*)) - -(defun grab-keyboard (screen) - (let ((ret (xlib:grab-keyboard (screen-root screen) :owner-p nil - :sync-keyboard-p nil :sync-pointer-p nil))) - (dformat 5 "vvv Grab keyboard: ~s~%" ret) - ret)) - -(defun ungrab-keyboard () - (let ((ret (xlib:ungrab-keyboard *display*))) - (dformat 5 "^^^ Ungrab keyboard: ~s~%" ret) - ret)) - -(defun warp-pointer (screen x y) - "Move the pointer to the specified location." - (let ((root (screen-root screen))) - (xlib:warp-pointer root x y))) - -(defun warp-pointer-relative (dx dy) - "Move the pointer by DX and DY relative to the current location." - (xlib:warp-pointer-relative *display* dx dy)) - - -;; Event handler functions - -(defparameter *event-fn-table* (make-hash-table) - "A hash of event types to functions") - -(defmacro define-stump-event-handler (event keys &body body) - (let ((fn-name (gensym)) - (event-slots (gensym))) - `(labels ((,fn-name (&rest ,event-slots &key ,@keys &allow-other-keys) - (declare (ignore ,event-slots)) - ,@body)) - (setf (gethash ,event *event-fn-table*) #',fn-name)))) - - ;(define-stump-event-handler :map-notify (event-window window override-redirect-p) - ; ) - -(defun handle-mode-line-window (xwin x y width height) - (declare (ignore width)) - (let ((ml (find-mode-line-window xwin))) - (when ml - (setf (xlib:drawable-height xwin) height) - (update-mode-line-position ml x y) - (resize-mode-line ml) - (sync-mode-line ml)))) - -(defun handle-unmanaged-window (xwin x y width height border-width value-mask) - "Call this function for windows that stumpwm isn't - managing. Basically just give the window what it wants." - (labels ((has-x (mask) (= 1 (logand mask 1))) - (has-y (mask) (= 2 (logand mask 2))) - (has-w (mask) (= 4 (logand mask 4))) - (has-h (mask) (= 8 (logand mask 8))) - (has-bw (mask) (= 16 (logand mask 16))) - ;; (has-stackmode (mask) (= 64 (logand mask 64))) - ) - (xlib:with-state (xwin) - (when (has-x value-mask) - (setf (xlib:drawable-x xwin) x)) - (when (has-y value-mask) - (setf (xlib:drawable-y xwin) y)) - (when (has-h value-mask) - (setf (xlib:drawable-height xwin) height)) - (when (has-w value-mask) - (setf (xlib:drawable-width xwin) width)) - (when (has-bw value-mask) - (setf (xlib:drawable-border-width xwin) border-width))))) - (defun update-configuration (win) ;; Send a synthetic configure-notify event so that the window ;; knows where it is onscreen. @@ -2812,46 +2283,6 @@ list of modifier symbols." (xlib:drawable-y (window-parent win)) (window-width win) (window-height win) 0)) -(defun handle-managed-window (window width height stack-mode value-mask) - "This is a managed window so deal with it appropriately." - ;; Grant the stack-mode change (if it's mapped) - (set-window-geometry window :width width :height height) - (maximize-window window) - (when (and (window-in-current-group-p window) - ;; stack-mode change? - (= 64 (logand value-mask 64))) - (case stack-mode - (:above - (maybe-raise-window window)))) - (update-configuration window)) - -(defun handle-window-move (win x y relative-to &optional (value-mask -1)) - (when *honor-window-moves* - (dformat 3 "Window requested new position ~D,~D relative to ~S~%" x y relative-to) - (labels ((has-x (mask) (= 1 (logand mask 1))) - (has-y (mask) (= 2 (logand mask 2)))) - (when (or (eq relative-to :root) (has-x value-mask) (has-y value-mask)) - (let* ((group (window-group win)) - (pos (if (eq relative-to :parent) - (list - (+ (xlib:drawable-x (window-parent win)) x) - (+ (xlib:drawable-y (window-parent win)) y)) - (list x y))) - (frame (apply #'find-frame group pos))) - (when frame - (pull-window win frame))))))) - -(define-stump-event-handler :configure-request (stack-mode #|parent|# window #|above-sibling|# x y width height border-width value-mask) - ;; Grant the configure request but then maximize the window after the granting. - (dformat 3 "CONFIGURE REQUEST address@hidden ~}~%" stack-mode window x y width height border-width value-mask) - (let ((win (find-window window))) - (cond - (win - (handle-window-move win x y :parent value-mask) - (handle-managed-window win width height stack-mode value-mask)) - ((handle-mode-line-window window x y width height)) - (t (handle-unmanaged-window window x y width height border-width value-mask))))) - (defun scale-screen (screen heads) "Scale all frames of all groups of SCREEN to match the dimensions of HEADS." @@ -2873,211 +2304,6 @@ list of modifier symbols." (scale-head screen oh nh) (add-head screen nh)))) -(define-stump-event-handler :configure-notify (stack-mode #|parent|# window #|above-sibling|# x y width height border-width value-mask) - (dformat 4 "CONFIGURE NOTIFY address@hidden ~}~%" stack-mode window x y width height border-width value-mask) - (let ((screen (find-screen window))) - (when screen - (let ((old-heads (copy-list (screen-heads screen)))) - (setf (screen-heads screen) nil) - (let ((new-heads (make-screen-heads screen (screen-root screen)))) - (setf (screen-heads screen) old-heads) - (cond - ((equalp old-heads new-heads) - (dformat 3 "Bogus configure-notify on root window of ~S~%" screen) t) - (t - (dformat 1 "Updating Xinerama configuration for ~S.~%" screen) - (if new-heads - (progn - (scale-screen screen new-heads) - (mapc 'sync-all-frame-windows (screen-groups screen)) - (update-mode-lines screen)) - (dformat 1 "Invalid configuration! ~S~%" new-heads))))))))) - -(define-stump-event-handler :map-request (parent send-event-p window) - (unless send-event-p - ;; This assumes parent is a root window and it should be. - (dformat 3 "map request: ~a ~a ~a~%" window parent (find-window window)) - (let ((screen (find-screen parent)) - (win (find-window window)) - (wwin (find-withdrawn-window window))) - ;; only absorb it if it's not already managed (it could be iconic) - (cond - (win (dformat 1 "map request for mapped window ~a~%" win)) - ((eq (xwin-type window) :dock) - (when wwin - (setf screen (window-screen wwin))) - (dformat 1 "window is dock-type. attempting to place in mode-line.") - (place-mode-line-window screen window) - ;; Some panels are broken and only set the dock type after they map and withdraw. - (when wwin - (setf (screen-withdrawn-windows screen) (delete wwin (screen-withdrawn-windows screen)))) - t) - (wwin (restore-window wwin)) - ((xlib:get-property window :_KDE_NET_WM_SYSTEM_TRAY_WINDOW_FOR) - ;; Do nothing if this is a systray window (the system tray - ;; will handle it, if there is one, and, if there isn't the - ;; user doesn't want this popping up as a managed window - ;; anyway. - t) - (t - (let ((window (process-mapped-window screen window))) - ;; Give it focus - (if (deny-request-p window *deny-map-request*) - (unless *suppress-deny-messages* - (if (eq (window-group window) (current-group)) - (echo-string (window-screen window) (format nil "'~a' denied map request" (window-name window))) - (echo-string (window-screen window) (format nil "'~a' denied map request in group ~a" (window-name window) (group-name (window-group window)))))) - (frame-raise-window (window-group window) (window-frame window) window - (if (eq (window-frame window) - (tile-group-current-frame (window-group window))) - t nil))))))))) - -(define-stump-event-handler :unmap-notify (send-event-p event-window window #|configure-p|#) - ;; There are two kinds of unmap notify events: the straight up - ;; ones where event-window and window are the same, and - ;; substructure unmap events when the event-window is the parent - ;; of window. - (dformat 2 "UNMAP: ~s ~s ~a~%" send-event-p (not (xlib:window-equal event-window window)) (find-window window)) - (unless (and (not send-event-p) - (not (xlib:window-equal event-window window))) - (let ((window (find-window window))) - ;; if we can't find the window then there's nothing we need to - ;; do. - (when window - (if (plusp (window-unmap-ignores window)) - (progn - (dformat 3 "decrement ignores! ~d~%" (window-unmap-ignores window)) - (decf (window-unmap-ignores window))) - (withdraw-window window)))))) - -;;(define-stump-event-handler :create-notify (#|window parent x y width height border-width|# override-redirect-p)) -;; (unless (or override-redirect-p -;; (internal-window-p (window-screen window) window)) -;; (process-new-window (window-screen window) window)) -;; (run-hook-with-args *new-window-hook* window))) - -(define-stump-event-handler :destroy-notify (send-event-p event-window window) - (unless (or send-event-p - (xlib:window-equal event-window window)) - ;; Ignore structure destroy notifies and only - ;; use substructure destroy notifiers. This way - ;; event-window is the window's parent. - (let ((win (or (find-window window) - (find-withdrawn-window window)))) - (if win - (destroy-window win) - (progn - (let ((ml (find-mode-line-window window))) - (when ml (destroy-mode-line-window ml)))))))) - -(defun read-from-keymap (kmap &optional update-fn) - "Read a sequence of keys from the user, guided by the keymap, -KMAP and return the binding or nil if the user hit an unbound sequence. - -The Caller is responsible for setting up the input focus." - (let* ((code-state (read-key-no-modifiers)) - (code (car code-state)) - (state (cdr code-state))) - (handle-keymap kmap code state nil nil update-fn))) - -(defun handle-keymap (kmap code state key-seq grab update-fn) - "Find the command mapped to the (code state) and return it." - ;; a symbol is assumed to have a hashtable as a value. - (dformat 1 "Awaiting key ~a~%" kmap) - (let ((keymap '())) - (when (and (symbolp kmap) - (boundp kmap) - (hash-table-p (symbol-value kmap))) - (setf - keymap kmap - kmap (symbol-value kmap))) - (check-type kmap hash-table) - (let* ((key (code-state->key code state)) - (cmd (lookup-key kmap key)) - (key-seq (cons key key-seq))) - (dformat 1 "key-press: ~S ~S ~S~%" key state cmd) - (run-hook-with-args *key-press-hook* key key-seq cmd) - (when update-fn - (funcall update-fn key-seq)) - (if cmd - (cond - ((or (hash-table-p cmd) - (and (symbolp cmd) - (boundp cmd) - (hash-table-p (symbol-value cmd)))) - (when grab - (grab-pointer (current-screen))) - (let* ((code-state (read-key-no-modifiers)) - (code (car code-state)) - (state (cdr code-state))) - (unwind-protect - (handle-keymap cmd code state key-seq nil update-fn) - (when grab (ungrab-pointer))))) - (t (values cmd key-seq))) - (if (find key (list (kbd "?") - (kbd "C-h")) - :test 'equalp) - (progn (display-keybinding keymap) (values t key-seq)) - (values nil key-seq)))))) - -(define-stump-event-handler :key-press (code state #|window|#) - (labels ((get-cmd (code state) - (with-focus (screen-key-window (current-screen)) - (handle-keymap *top-map* code state nil t nil)))) - (unwind-protect - ;; modifiers can sneak in with a race condition. so avoid that. - (unless (is-modifier code) - (multiple-value-bind (cmd key-seq) (get-cmd code state) - (cond - ((eq cmd t)) - (cmd - (unmap-message-window (current-screen)) - (interactive-command cmd) t) - (t (message "~{~a ~}not bound." (mapcar 'print-key (nreverse key-seq)))))))))) - -(defun bytes-to-window (bytes) - "A sick hack to assemble 4 bytes into a 32 bit number. This is -because ratpoison sends the rp_command_request window in 8 byte -chunks." - (+ (first bytes) - (ash (second bytes) 8) - (ash (third bytes) 16) - (ash (fourth bytes) 24))) - -(defun handle-rp-commands (root) - "Handle a ratpoison style command request." - (labels ((one-cmd () - (multiple-value-bind (win type format bytes-after) (xlib:get-property root :rp_command_request :end 4 :delete-p t) - (declare (ignore type format)) - (setf win (xlib::lookup-window *display* (bytes-to-window win))) - (when (xlib:window-p win) - (let* ((data (xlib:get-property win :rp_command)) - (interactive-p (car data)) - (cmd (map 'string 'code-char (nbutlast (cdr data))))) - (declare (ignore interactive-p)) - (interactive-command cmd) - (xlib:change-property win :rp_command_result (map 'list 'char-code "0TODO") :string 8) - (xlib:display-finish-output *display*))) - bytes-after))) - (loop while (> (one-cmd) 0)))) - -(defun handle-stumpwm-commands (root) - "Handle a StumpWM style command request." - (let* ((win root) - (screen (find-screen root)) - (data (xlib:get-property win :stumpwm_command :delete-p t)) - (cmd (map 'string 'code-char data))) - (let ((msgs (screen-last-msg screen)) - (hlts (screen-last-msg-highlights screen)) - (*executing-stumpwm-command* t)) - (setf (screen-last-msg screen) '() - (screen-last-msg-highlights screen) '()) - (interactive-command cmd) - (xlib:change-property win :stumpwm_command_result (map 'list 'char-code (format nil "~{~{~a~%~}~}" (nreverse (screen-last-msg screen)))) :string 8) - (setf (screen-last-msg screen) msgs - (screen-last-msg-highlights screen) hlts)) - (xlib:display-finish-output *display*))) - (defun update-window-properties (window atom) (case atom (:wm_name @@ -3107,46 +2333,6 @@ chunks." ;; FIXME: what about when properties are REMOVED? (update-fullscreen window 1))))))) -(define-stump-event-handler :property-notify (window atom state) - (dformat 2 "property notify ~s ~s ~s~%" window atom state) - (case atom - (:rp_command_request - ;; we will only find the screen if window is a root window, which - ;; is the only place we listen for ratpoison commands. - (let* ((screen (find-screen window))) - (when (and (eq state :new-value) - screen) - (handle-rp-commands window)))) - (:stumpwm_command - ;; RP commands are too weird and problematic, KISS. - (let* ((screen (find-screen window))) - (when (and (eq state :new-value) - screen) - (handle-stumpwm-commands window)))) - (t - (let ((window (find-window window))) - (when window - (update-window-properties window atom)))))) - -(define-stump-event-handler :mapping-notify (request start count) - ;; We could be a bit more intelligent about when to update the - ;; modifier map, but I don't think it really matters. - (xlib:mapping-notify *display* request start count) - (update-modifier-map) - (sync-keys)) - -(define-stump-event-handler :selection-request (requestor property selection target time) - (send-selection requestor property selection target time)) - -(define-stump-event-handler :selection-clear () - (setf *x-selection* nil)) - -(defun find-message-window-screen (win) - "Return the screen, if any, that message window WIN belongs." - (dolist (screen *screen-list*) - (when (xlib:window-equal (screen-message-window screen) win) - (return screen)))) - (defun draw-cross (screen window x y width height) (xlib:draw-line window (screen-frame-outline-gc screen) @@ -3158,36 +2344,6 @@ chunks." x (+ y height) (+ x width) y)) -(define-stump-event-handler :exposure (window x y width height count) - (let (screen ml) - (when (zerop count) - (cond - ((setf screen (find-screen window)) - ;; root exposed - (show-frame-outline (screen-current-group screen) nil)) - ((setf screen (find-message-window-screen window)) - ;; message window exposed - (if (plusp (screen-ignore-msg-expose screen)) - (decf (screen-ignore-msg-expose screen)) - (redraw-current-message screen))) - ((setf ml (find-mode-line-window window)) - (setf screen (mode-line-screen ml)) - (redraw-mode-line ml t))) - ;; Show the area. - (when (and *debug-expose-events* screen) - (draw-cross screen window x y width height))))) - - -(define-stump-event-handler :reparent-notify (window parent) - (let ((win (find-window window))) - (when (and win - (not (xlib:window-equal parent (window-parent win)))) - ;; reparent it back - (unless (eq (xlib:window-map-state (window-xwin win)) :unmapped) - (incf (window-unmap-ignores win))) - (xlib:reparent-window (window-xwin win) (window-parent win) 0 0)))) - - ;;; Fullscreen functions (defun activate-fullscreen (window) @@ -3231,208 +2387,6 @@ chunks." (echo-string (window-screen window) (format nil "'~a' denied raise request in group ~a" (window-name window) (group-name (window-group window)))))) (focus-all window))) -(define-stump-event-handler :client-message (window type #|format|# data) - (dformat 2 "client message: ~s ~s~%" type data) - (case type - (:_NET_CURRENT_DESKTOP ;switch desktop - (let* ((screen (find-screen window)) - (n (elt data 0)) - (group (and screen - (< n (length (screen-groups screen))) - (elt (sort-groups screen) n)))) - (when group - (switch-to-group group)))) - (:_NET_WM_DESKTOP ;move window to desktop - (let* ((our-window (find-window window)) - (screen (when our-window - (window-screen our-window))) - (n (elt data 0)) - (group (and screen - (< n (length (screen-groups screen))) - (elt (sort-groups screen) n)))) - (when (and our-window group) - (move-window-to-group our-window group)))) - (:_NET_ACTIVE_WINDOW - (let ((our-window (find-window window)) - (source (elt data 0))) - (when our-window - (if (= source 2) ;request is from a pager - (focus-all our-window) - (maybe-raise-window our-window))))) - (:_NET_CLOSE_WINDOW - (let ((our-window (find-window window))) - (when our-window - (delete-window our-window)))) - (:_NET_WM_STATE - (let ((our-window (find-window window))) - (when our-window - (let ((action (elt data 0)) - (p1 (elt data 1)) - (p2 (elt data 2))) - (dolist (p (list p1 p2)) - (unless (= p 0) - (case (xlib:atom-name *display* p) - (:_NET_WM_STATE_FULLSCREEN - (update-fullscreen our-window action))))))))) - (:_NET_MOVERESIZE_WINDOW - (let ((our-window (find-window window))) - (when our-window - (let ((x (elt data 1)) - (y (elt data 2))) - (dformat 3 "!!! Data: ~S~%" data) - (handle-window-move our-window x y :relative :root))))) - (t - (dformat 2 "ignored message~%")))) - -(define-stump-event-handler :focus-out (window mode kind) - (dformat 5 "address@hidden ~}~%" window mode kind)) - -;;; Mouse focus - -(defun focus-all (win) - "Focus the window, frame, group and screen belonging to WIN. Raise -the window in it's frame." - (when (and win (window-frame win)) - (unmap-message-window (window-screen win)) - (switch-to-screen (window-screen win)) - (let ((frame (window-frame win)) - (group (window-group win))) - (switch-to-group group) - (frame-raise-window group frame win)))) - -(define-stump-event-handler :enter-notify (window mode) - (when (and window (eq mode :normal) (eq *mouse-focus-policy* :sloppy)) - (let ((win (find-window window))) - (when (and win (find win (top-windows))) - (focus-all win))))) - -(define-stump-event-handler :button-press (window code x y child time) - ;; Pass click to client - (xlib:allow-events *display* :replay-pointer time) - (let (screen ml win) - (cond - ((and (setf screen (find-screen window)) (not child)) - (when (and (eq *mouse-focus-policy* :click) - *root-click-focuses-frame*) - (let* ((group (screen-current-group screen)) - (frame (find-frame group x y))) - (when frame - (focus-frame group frame)))) - (run-hook-with-args *root-click-hook* screen code x y)) - ((setf ml (find-mode-line-window window)) - (run-hook-with-args *mode-line-click-hook* ml code x y)) - ((setf win (find-window-by-parent window (visible-windows))) - (when (eq *mouse-focus-policy* :click) - (focus-all win)))))) - -;; Handling event :KEY-PRESS -;; (:DISPLAY # :EVENT-KEY :KEY-PRESS :EVENT-CODE 2 :SEND-EVENT-P NIL :CODE 45 :SEQUENCE 1419 :TIME 98761213 :ROOT # :WINDOW # :EVENT-WINDOW # :CHILD -;; # :ROOT-X 754 :ROOT-Y 223 :X 753 :Y 222 :STATE 4 :SAME-SCREEN-P T) -;; H - -(defun handle-event (&rest event-slots &key display event-key &allow-other-keys) - (declare (ignore display)) - (dformat 1 ">>> ~S~%" event-key) - (let ((eventfn (gethash event-key *event-fn-table*))) - (when eventfn - (handler-case - (progn - ;; This is not the stumpwm top level, but if the restart - ;; is in the top level then it seems the event being - ;; processed isn't popped off the stack and is immediately - ;; reprocessed after restarting to the top level. So fake - ;; it, and put the restart here. - (with-simple-restart (top-level "Return to stumpwm's top level") - (apply eventfn event-slots)) - (xlib:display-finish-output *display*)) - ((or xlib:window-error xlib:drawable-error) (c) - ;; Asynchronous errors are handled in the error - ;; handler. Synchronous errors like trying to get the window - ;; hints on a deleted window are caught and ignored here. We - ;; do this inside the event handler so that the event is - ;; handled. If we catch it higher up the event will not be - ;; flushed from the queue and we'll get ourselves into an - ;; infinite loop. - (dformat 4 "ignore synchronous ~a~%" c)))) - (dformat 2 "<<< ~S~%" event-key) - t)) - -;;; Selection - -(defun export-selection () - (let* ((screen (current-screen)) - (selwin (screen-focus-window (current-screen))) - (root (screen-root screen))) - (xlib:set-selection-owner *display* :primary selwin) - (unless (eq (xlib:selection-owner *display* :primary) selwin) - (error "Can't set selection owner")) - ;; also set the cut buffer for completeness - (xlib:change-property root :cut-buffer0 *x-selection* :string 8 :transform #'xlib:char->card8 - :mode :replace))) - -(defun set-x-selection (text) - "Set the X11 selection string to @var{string}." - (setf *x-selection* text) - (export-selection)) - -(defun send-selection (requestor property selection target time) - (dformat 1 "send-selection ~s ~s ~s ~s ~s~%" requestor property selection target time) - (cond - ;; they're requesting what targets are available - ((eq target :targets) - (xlib:change-property requestor property (list :targets :string) target 8 :mode :replace)) - ;; send them a string - ((find target '(:string )) - (xlib:change-property requestor property *x-selection* :string 8 :mode :replace :transform #'xlib:char->card8)) - ;; we don't know how to handle anything else - (t - (setf property nil))) - (xlib:send-event requestor :selection-notify nil - :display *display* - :window requestor - :selection selection - :property property - :target target - :time time) - (xlib:display-finish-output *display*)) - -(defun get-x-selection (&optional timeout) - "Return the x selection no matter what client own it." - (labels ((wait-for-selection (&rest event-slots &key display event-key &allow-other-keys) - (declare (ignore display)) - (when (eq event-key :selection-notify) - (destructuring-bind (&key window property &allow-other-keys) event-slots - (if property - (xlib:get-property window property :type :string :result-type 'string :transform #'xlib:card8->char :delete-p t) - ""))))) - (if *x-selection* - *x-selection* - (progn - (xlib:convert-selection :primary :string (screen-input-window (current-screen)) :stumpwm-selection) - ;; Note: this may spend longer than timeout in this loop but it will eventually return. - (let ((time (get-internal-real-time))) - (loop for ret = (xlib:process-event *display* :handler #'wait-for-selection :timeout timeout :discard-p nil) - when (or ret - (> (/ (- time (get-internal-real-time)) internal-time-units-per-second) - timeout)) - ;; make sure we return a string - return (or ret ""))))))) - -;;; Top map push/popping - -(defvar *top-map-list* nil) - -(defun push-top-map (new-top) - (push *top-map* *top-map-list*) - (setf *top-map* new-top) - (sync-keys)) - -(defun pop-top-map () - (when *top-map-list* - (setf *top-map* (pop *top-map-list*)) - (sync-keys) - t)) - (defmacro save-frame-excursion (&body body) "Execute body and then restore the current frame." (let ((oframe (gensym "OFRAME")) diff --git a/fdump.lisp b/fdump.lisp index ff7e1de..063f4c5 100644 --- a/fdump.lisp +++ b/fdump.lisp @@ -79,27 +79,6 @@ (*print-pretty* t)) (prin1 foo fp))))) -(defcommand dump-group-to-file (file) ((:rest "Dump To File: ")) - "Dumps the frames of the current group of the current screen to the named file." - (dump-to-file (dump-group (current-group)) file) - (message "Group dumped")) - -(defcommand-alias dump-group dump-group-to-file) - -(defcommand dump-screen-to-file (file) ((:rest "Dump To File: ")) - "Dumps the frames of all groups of the current screen to the named file" - (dump-to-file (dump-screen (current-screen)) file) - (message "Screen dumped")) - -(defcommand-alias dump-screen dump-screen-to-file) - -(defcommand dump-desktop-to-file (file) ((:rest "Dump To File: ")) - "Dumps the frames of all groups of all screens to the named file" - (dump-to-file (dump-desktop) file) - (message "Desktop dumped")) - -(defcommand-alias dump-desktop dump-desktop-to-file) - ;;; @@ -192,9 +171,4 @@ (t (message "Don't know how to restore ~a" dump))))) -(defcommand restore (file) ((:rest "Restore From File: ")) - "Restores screen, groups, or frames from named file, depending on file's contents." - (restore-from-file file)) - -(defcommand place-existing-windows () () - (sync-window-placement)) +;;; fdump.lisp ends here diff --git a/frame.lisp b/frame.lisp new file mode 100644 index 0000000..9a1abb2 --- /dev/null +++ b/frame.lisp @@ -0,0 +1,159 @@ +;; Copyright (C) 2003, 2008 * +;; +;; This file is part of stumpwm. +;; +;; stumpwm is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; stumpwm is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA +;; +;; Commentary: +;; +;; Commands for manipulating frames, extracted from user.lisp. +;; +;; * user.lisp Copyright (C) 2003 Shawn Betts +;; +;; Code: + +;;; Frame splitting + +(in-package :stumpwm) + +(defun split-frame-in-dir (group dir) + (let ((f (tile-group-current-frame group))) + (if (split-frame group dir) + (progn + (when (frame-window f) + (update-window-border (frame-window f))) + (show-frame-indicator group)) + (message "Cannot split smaller than minimum size.")))) + +(defun clear-frame (frame group) + "Clear the given frame." + (frame-raise-window group frame nil (eq (tile-group-current-frame group) frame))) + +;;; Frame focus + +(defun focus-frame-next-sibling (group) + (let* ((sib (next-sibling (tile-group-frame-tree group) + (tile-group-current-frame group)))) + (when sib + (focus-frame group (tree-accum-fn sib + (lambda (x y) + (declare (ignore y)) + x) + 'identity)) + (show-frame-indicator group)))) + +(defun focus-last-frame (group) + ;; make sure the last frame still exists in the frame tree + (when (and (tile-group-last-frame group) + (find (tile-group-last-frame group) (group-frames group))) + (focus-frame group (tile-group-last-frame group)))) + +(defun focus-frame-after (group frames) + "Given a list of frames focus the next one in the list after +the current frame." + (let ((rest (cdr (member (tile-group-current-frame group) frames :test 'eq)))) + (focus-frame group + (if (null rest) + (car frames) + (car rest))))) + +(defun focus-next-frame (group) + (focus-frame-after group (group-frames group))) + +(defun focus-prev-frame (group) + (focus-frame-after group (nreverse (group-frames group)))) + +(defun choose-frame-by-number (group) + "show a number in the corner of each frame and wait for the user to +select one. Returns the selected frame or nil if aborted." + (let* ((wins (progn + (draw-frame-outlines group) + (draw-frame-numbers group))) + (ch (read-one-char (group-screen group))) + (num (read-from-string (string ch) nil nil))) + (dformat 3 "read ~S ~S~%" ch num) + (mapc #'xlib:destroy-window wins) + (clear-frame-outlines group) + (find ch (group-frames group) + :test 'char= + :key 'get-frame-number-translation))) + +;;; Frame cooperation + +(defun get-edge (frame edge) + "Returns the specified edge of FRAME. Valid values for EDGE are :TOP, :BOTTOM, :LEFT, and :RIGHT. + An edge is a START, END, and OFFSET. For horizontal edges, START is the left coordinate, END is + the right coordinate, and OFFSET is the Y coordinate. Similarly, for vertical lines, START is + top, END is bottom, and OFFSET is X coordinate." + (let* ((x1 (frame-x frame)) + (y1 (frame-y frame)) + (x2 (+ x1 (frame-width frame))) + (y2 (+ y1 (frame-height frame)))) + (ecase edge + (:top + (values x1 x2 y1)) + (:bottom + (values x1 x2 y2)) + (:left + (values y1 y2 x1)) + (:right + (values y1 y2 x2))))) + +(defun neighbour (direction frame frameset) + "Returns the best neighbour of FRAME in FRAMESET on the DIRECTION edge. + Valid directions are :UP, :DOWN, :LEFT, :RIGHT. + eg: (NEIGHBOUR :UP F FS) finds the frame in FS that is the 'best' + neighbour above F." + (let ((src-edge (ecase direction + (:up :top) + (:down :bottom) + (:left :left) + (:right :right))) + (opposite (ecase direction + (:up :bottom) + (:down :top) + (:left :right) + (:right :left))) + (best-frame nil) + (best-overlap 0)) + (multiple-value-bind (src-s src-e src-offset) + (get-edge frame src-edge) + (dolist (f frameset) + (multiple-value-bind (s e offset) + (get-edge f opposite) + (let ((overlap (- (min src-e e) + (max src-s s)))) + ;; Two edges are neighbours if they have the same offset and their starts and ends + ;; overlap. We want to find the neighbour that overlaps the most. + (when (and (= src-offset offset) + (>= overlap best-overlap)) + (setf best-frame f) + (setf best-overlap overlap)))))) + best-frame)) + +;;; Frame movement + +(defun move-focus-and-or-window (dir &optional win-p) + (let* ((group (current-group)) + (direction (intern (string-upcase dir) :keyword)) + (new-frame (neighbour direction (tile-group-current-frame group) (group-frames group))) + (window (current-window))) + (when new-frame + (if (and win-p window) + (pull-window window new-frame) + (focus-frame group new-frame))))) + +;;; frame.lisp ends here diff --git a/group.lisp b/group.lisp new file mode 100644 index 0000000..6978186 --- /dev/null +++ b/group.lisp @@ -0,0 +1,68 @@ +;; Copyright (C) 2003, 2008 * +;; +;; This file is part of stumpwm. +;; +;; stumpwm is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; stumpwm is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA +;; +;; Commentary: +;; +;; Commands for manipulating groups, extracted from user.lisp. +;; +;; * user.lisp Copyright (C) 2003 Shawn Betts +;; +;; Code: + +(in-package :stumpwm) + +(defun select-group (screen query) + "Attempt to match string QUERY against group number or partial name." + (let (match + (num (ignore-errors (parse-integer query)))) + (labels ((match (grp) + (let* ((name (group-name grp)) + (end (min (length name) (length query)))) + ;; try by name or number + (or (string-equal name query :end1 end :end2 end) + (eql (group-number grp) num))))) + (unless (null query) + (setf match (find-if #'match (screen-groups screen)))) + match))) + +;; FIXME: groups are to screens exactly as windows are to +;; groups. There is a lot of duplicate code that could be globbed +;; together. + +(defun group-forward (current list) + (let ((ng (next-group current list))) + (when ng + (switch-to-group ng)))) + +(defun echo-groups (screen fmt &optional verbose (wfmt *window-format*)) + "Print a list of the windows to the screen." + (let* ((groups (sort-groups screen)) + (names (mapcan (lambda (g) + (list* + (format-expand *group-formatters* fmt g) + (when verbose + (mapcar (lambda (w) + (format-expand *window-formatters* + (concatenate 'string " " wfmt) + w)) + (sort-windows g))))) + (if *list-hidden-groups* groups (non-hidden-groups groups))))) + (echo-string-list screen names))) + +;;; group.lisp ends here diff --git a/handler.lisp b/handler.lisp new file mode 100644 index 0000000..66e215b --- /dev/null +++ b/handler.lisp @@ -0,0 +1,500 @@ +;; Copyright (C) 2003, 2008 * +;; +;; This file is part of stumpwm. +;; +;; stumpwm is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; stumpwm is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA +;; +;; Commentary: +;; +;; Handler-related code from core.lisp. +;; +;; * core.lisp Copyright (C) 2003 Shawn Betts +;; +;; Code: + +(in-package :stumpwm) + +(defparameter *event-fn-table* (make-hash-table) + "A hash of event types to functions") + +(defmacro define-stump-event-handler (event keys &body body) + (let ((fn-name (gensym)) + (event-slots (gensym))) + `(labels ((,fn-name (&rest ,event-slots &key ,@keys &allow-other-keys) + (declare (ignore ,event-slots)) + ,@body)) + (setf (gethash ,event *event-fn-table*) #',fn-name)))) + + ;; (define-stump-event-handler + ;; :map-notify + ;; (event-window window override-redirect-p)) + + +(defun handle-managed-window (window width height stack-mode value-mask) + "This is a managed window so deal with it appropriately." + ;; Grant the stack-mode change (if it's mapped) + (set-window-geometry window :width width :height height) + (maximize-window window) + (when (and (window-in-current-group-p window) + ;; stack-mode change? + (= 64 (logand value-mask 64))) + (case stack-mode + (:above + (maybe-raise-window window)))) + (update-configuration window)) + +(defun handle-mode-line-window (xwin x y width height) + (declare (ignore width)) + (let ((ml (find-mode-line-window xwin))) + (when ml + (setf (xlib:drawable-height xwin) height) + (update-mode-line-position ml x y) + (resize-mode-line ml) + (sync-mode-line ml)))) + +(defun handle-unmanaged-window (xwin x y width height border-width value-mask) + "Call this function for windows that stumpwm isn't + managing. Basically just give the window what it wants." + (labels ((has-x (mask) (= 1 (logand mask 1))) + (has-y (mask) (= 2 (logand mask 2))) + (has-w (mask) (= 4 (logand mask 4))) + (has-h (mask) (= 8 (logand mask 8))) + (has-bw (mask) (= 16 (logand mask 16))) + ;; (has-stackmode (mask) (= 64 (logand mask 64))) + ) + (xlib:with-state (xwin) + (when (has-x value-mask) + (setf (xlib:drawable-x xwin) x)) + (when (has-y value-mask) + (setf (xlib:drawable-y xwin) y)) + (when (has-h value-mask) + (setf (xlib:drawable-height xwin) height)) + (when (has-w value-mask) + (setf (xlib:drawable-width xwin) width)) + (when (has-bw value-mask) + (setf (xlib:drawable-border-width xwin) border-width))))) + +(defun handle-window-move (win x y relative-to &optional (value-mask -1)) + (when *honor-window-moves* + (dformat 3 "Window requested new position ~D,~D relative to ~S~%" x y relative-to) + (labels ((has-x (mask) (= 1 (logand mask 1))) + (has-y (mask) (= 2 (logand mask 2)))) + (when (or (eq relative-to :root) (has-x value-mask) (has-y value-mask)) + (let* ((group (window-group win)) + (pos (if (eq relative-to :parent) + (list + (+ (xlib:drawable-x (window-parent win)) x) + (+ (xlib:drawable-y (window-parent win)) y)) + (list x y))) + (frame (apply #'find-frame group pos))) + (when frame + (pull-window win frame))))))) + +(defun bytes-to-window (bytes) + "A sick hack to assemble 4 bytes into a 32 bit number. This is +because ratpoison sends the rp_command_request window in 8 byte +chunks." + (+ (first bytes) + (ash (second bytes) 8) + (ash (third bytes) 16) + (ash (fourth bytes) 24))) + +(defun handle-rp-commands (root) + "Handle a ratpoison style command request." + (labels ((one-cmd () + (multiple-value-bind (win type format bytes-after) (xlib:get-property root :rp_command_request :end 4 :delete-p t) + (declare (ignore type format)) + (setf win (xlib::lookup-window *display* (bytes-to-window win))) + (when (xlib:window-p win) + (let* ((data (xlib:get-property win :rp_command)) + (interactive-p (car data)) + (cmd (map 'string 'code-char (nbutlast (cdr data))))) + (declare (ignore interactive-p)) + (interactive-command cmd) + (xlib:change-property win :rp_command_result (map 'list 'char-code "0TODO") :string 8) + (xlib:display-finish-output *display*))) + bytes-after))) + (loop while (> (one-cmd) 0)))) + +(defun handle-stumpwm-commands (root) + "Handle a StumpWM style command request." + (let* ((win root) + (screen (find-screen root)) + (data (xlib:get-property win :stumpwm_command :delete-p t)) + (cmd (map 'string 'code-char data))) + (let ((msgs (screen-last-msg screen)) + (hlts (screen-last-msg-highlights screen)) + (*executing-stumpwm-command* t)) + (setf (screen-last-msg screen) '() + (screen-last-msg-highlights screen) '()) + (interactive-command cmd) + (xlib:change-property win :stumpwm_command_result (map 'list 'char-code (format nil "~{~{~a~%~}~}" (nreverse (screen-last-msg screen)))) :string 8) + (setf (screen-last-msg screen) msgs + (screen-last-msg-highlights screen) hlts)) + (xlib:display-finish-output *display*))) + +;;; Handlers + +(define-stump-event-handler :configure-request (stack-mode #|parent|# window #|above-sibling|# x y width height border-width value-mask) + ;; Grant the configure request but then maximize the window after the granting. + (dformat 3 "CONFIGURE REQUEST address@hidden ~}~%" stack-mode window x y width height border-width value-mask) + (let ((win (find-window window))) + (cond + (win + (handle-window-move win x y :parent value-mask) + (handle-managed-window win width height stack-mode value-mask)) + ((handle-mode-line-window window x y width height)) + (t (handle-unmanaged-window window x y width height border-width value-mask))))) + +(define-stump-event-handler :configure-notify (stack-mode #|parent|# window #|above-sibling|# x y width height border-width value-mask) + (dformat 4 "CONFIGURE NOTIFY address@hidden ~}~%" stack-mode window x y width height border-width value-mask) + (let ((screen (find-screen window))) + (when screen + (let ((old-heads (copy-list (screen-heads screen)))) + (setf (screen-heads screen) nil) + (let ((new-heads (make-screen-heads screen (screen-root screen)))) + (setf (screen-heads screen) old-heads) + (cond + ((equalp old-heads new-heads) + (dformat 3 "Bogus configure-notify on root window of ~S~%" screen) t) + (t + (dformat 1 "Updating Xinerama configuration for ~S.~%" screen) + (if new-heads + (progn + (scale-screen screen new-heads) + (mapc 'sync-all-frame-windows (screen-groups screen)) + (update-mode-lines screen)) + (dformat 1 "Invalid configuration! ~S~%" new-heads))))))))) + +(define-stump-event-handler :map-request (parent send-event-p window) + (unless send-event-p + ;; This assumes parent is a root window and it should be. + (dformat 3 "map request: ~a ~a ~a~%" window parent (find-window window)) + (let ((screen (find-screen parent)) + (win (find-window window)) + (wwin (find-withdrawn-window window))) + ;; only absorb it if it's not already managed (it could be iconic) + (cond + (win (dformat 1 "map request for mapped window ~a~%" win)) + ((eq (xwin-type window) :dock) + (when wwin + (setf screen (window-screen wwin))) + (dformat 1 "window is dock-type. attempting to place in mode-line.") + (place-mode-line-window screen window) + ;; Some panels are broken and only set the dock type after they map and withdraw. + (when wwin + (setf (screen-withdrawn-windows screen) (delete wwin (screen-withdrawn-windows screen)))) + t) + (wwin (restore-window wwin)) + ((xlib:get-property window :_KDE_NET_WM_SYSTEM_TRAY_WINDOW_FOR) + ;; Do nothing if this is a systray window (the system tray + ;; will handle it, if there is one, and, if there isn't the + ;; user doesn't want this popping up as a managed window + ;; anyway. + t) + (t + (let ((window (process-mapped-window screen window))) + ;; Give it focus + (if (deny-request-p window *deny-map-request*) + (unless *suppress-deny-messages* + (if (eq (window-group window) (current-group)) + (echo-string (window-screen window) (format nil "'~a' denied map request" (window-name window))) + (echo-string (window-screen window) (format nil "'~a' denied map request in group ~a" (window-name window) (group-name (window-group window)))))) + (frame-raise-window (window-group window) (window-frame window) window + (if (eq (window-frame window) + (tile-group-current-frame (window-group window))) + t nil))))))))) + +(define-stump-event-handler :unmap-notify (send-event-p event-window window #|configure-p|#) + ;; There are two kinds of unmap notify events: the straight up + ;; ones where event-window and window are the same, and + ;; substructure unmap events when the event-window is the parent + ;; of window. + (dformat 2 "UNMAP: ~s ~s ~a~%" send-event-p (not (xlib:window-equal event-window window)) (find-window window)) + (unless (and (not send-event-p) + (not (xlib:window-equal event-window window))) + (let ((window (find-window window))) + ;; if we can't find the window then there's nothing we need to + ;; do. + (when window + (if (plusp (window-unmap-ignores window)) + (progn + (dformat 3 "decrement ignores! ~d~%" (window-unmap-ignores window)) + (decf (window-unmap-ignores window))) + (withdraw-window window)))))) + +;;(define-stump-event-handler :create-notify (#|window parent x y width height border-width|# override-redirect-p)) +;; (unless (or override-redirect-p +;; (internal-window-p (window-screen window) window)) +;; (process-new-window (window-screen window) window)) +;; (run-hook-with-args *new-window-hook* window))) + +(define-stump-event-handler :destroy-notify (send-event-p event-window window) + (unless (or send-event-p + (xlib:window-equal event-window window)) + ;; Ignore structure destroy notifies and only + ;; use substructure destroy notifiers. This way + ;; event-window is the window's parent. + (let ((win (or (find-window window) + (find-withdrawn-window window)))) + (if win + (destroy-window win) + (progn + (let ((ml (find-mode-line-window window))) + (when ml (destroy-mode-line-window ml)))))))) + +(defun handle-keymap (kmap code state key-seq grab update-fn) + "Find the command mapped to the (code state) and return it." + ;; a symbol is assumed to have a hashtable as a value. + (dformat 1 "Awaiting key ~a~%" kmap) + (let ((keymap '())) + (when (and (symbolp kmap) + (boundp kmap) + (hash-table-p (symbol-value kmap))) + (setf + keymap kmap + kmap (symbol-value kmap))) + (check-type kmap hash-table) + (let* ((key (code-state->key code state)) + (cmd (lookup-key kmap key)) + (key-seq (cons key key-seq))) + (dformat 1 "key-press: ~S ~S ~S~%" key state cmd) + (run-hook-with-args *key-press-hook* key key-seq cmd) + (when update-fn + (funcall update-fn key-seq)) + (if cmd + (cond + ((or (hash-table-p cmd) + (and (symbolp cmd) + (boundp cmd) + (hash-table-p (symbol-value cmd)))) + (when grab + (grab-pointer (current-screen))) + (let* ((code-state (read-key-no-modifiers)) + (code (car code-state)) + (state (cdr code-state))) + (unwind-protect + (handle-keymap cmd code state key-seq nil update-fn) + (when grab (ungrab-pointer))))) + (t (values cmd key-seq))) + (if (find key (list (kbd "?") + (kbd "C-h")) + :test 'equalp) + (progn (display-keybinding keymap) (values t key-seq)) + (values nil key-seq)))))) + +(define-stump-event-handler :key-press (code state #|window|#) + (labels ((get-cmd (code state) + (with-focus (screen-key-window (current-screen)) + (handle-keymap *top-map* code state nil t nil)))) + (unwind-protect + ;; modifiers can sneak in with a race condition. so avoid that. + (unless (is-modifier code) + (multiple-value-bind (cmd key-seq) (get-cmd code state) + (cond + ((eq cmd t)) + (cmd + (unmap-message-window (current-screen)) + (interactive-command cmd) t) + (t (message "~{~a ~}not bound." (mapcar 'print-key (nreverse key-seq)))))))))) + +(define-stump-event-handler :property-notify (window atom state) + (dformat 2 "property notify ~s ~s ~s~%" window atom state) + (case atom + (:rp_command_request + ;; we will only find the screen if window is a root window, which + ;; is the only place we listen for ratpoison commands. + (let* ((screen (find-screen window))) + (when (and (eq state :new-value) + screen) + (handle-rp-commands window)))) + (:stumpwm_command + ;; RP commands are too weird and problematic, KISS. + (let* ((screen (find-screen window))) + (when (and (eq state :new-value) + screen) + (handle-stumpwm-commands window)))) + (t + (let ((window (find-window window))) + (when window + (update-window-properties window atom)))))) + +(define-stump-event-handler :mapping-notify (request start count) + ;; We could be a bit more intelligent about when to update the + ;; modifier map, but I don't think it really matters. + (xlib:mapping-notify *display* request start count) + (update-modifier-map) + (sync-keys)) + +(define-stump-event-handler :selection-request (requestor property selection target time) + (send-selection requestor property selection target time)) + +(define-stump-event-handler :selection-clear () + (setf *x-selection* nil)) + +(define-stump-event-handler :exposure (window x y width height count) + (let (screen ml) + (when (zerop count) + (cond + ((setf screen (find-screen window)) + ;; root exposed + (show-frame-outline (screen-current-group screen) nil)) + ((setf screen (find-message-window-screen window)) + ;; message window exposed + (if (plusp (screen-ignore-msg-expose screen)) + (decf (screen-ignore-msg-expose screen)) + (redraw-current-message screen))) + ((setf ml (find-mode-line-window window)) + (setf screen (mode-line-screen ml)) + (redraw-mode-line ml t))) + ;; Show the area. + (when (and *debug-expose-events* screen) + (draw-cross screen window x y width height))))) + +(define-stump-event-handler :reparent-notify (window parent) + (let ((win (find-window window))) + (when (and win + (not (xlib:window-equal parent (window-parent win)))) + ;; reparent it back + (unless (eq (xlib:window-map-state (window-xwin win)) :unmapped) + (incf (window-unmap-ignores win))) + (xlib:reparent-window (window-xwin win) (window-parent win) 0 0)))) + +(define-stump-event-handler :focus-out (window mode kind) + (dformat 5 "address@hidden ~}~%" window mode kind)) + +(define-stump-event-handler :enter-notify (window mode) + (when (and window (eq mode :normal) (eq *mouse-focus-policy* :sloppy)) + (let ((win (find-window window))) + (when (and win (find win (top-windows))) + (focus-all win))))) + +(define-stump-event-handler :button-press (window code x y child time) + ;; Pass click to client + (xlib:allow-events *display* :replay-pointer time) + (let (screen ml win) + (cond + ((and (setf screen (find-screen window)) (not child)) + (when (and (eq *mouse-focus-policy* :click) + *root-click-focuses-frame*) + (let* ((group (screen-current-group screen)) + (frame (find-frame group x y))) + (when frame + (focus-frame group frame)))) + (run-hook-with-args *root-click-hook* screen code x y)) + ((setf ml (find-mode-line-window window)) + (run-hook-with-args *mode-line-click-hook* ml code x y)) + ((setf win (find-window-by-parent window (visible-windows))) + (when (eq *mouse-focus-policy* :click) + (focus-all win)))))) + +(define-stump-event-handler :client-message (window type #|format|# data) + (dformat 2 "client message: ~s ~s~%" type data) + (case type + (:_NET_CURRENT_DESKTOP ;switch desktop + (let* ((screen (find-screen window)) + (n (elt data 0)) + (group (and screen + (< n (length (screen-groups screen))) + (elt (sort-groups screen) n)))) + (when group + (switch-to-group group)))) + (:_NET_WM_DESKTOP ;move window to desktop + (let* ((our-window (find-window window)) + (screen (when our-window + (window-screen our-window))) + (n (elt data 0)) + (group (and screen + (< n (length (screen-groups screen))) + (elt (sort-groups screen) n)))) + (when (and our-window group) + (move-window-to-group our-window group)))) + (:_NET_ACTIVE_WINDOW + (let ((our-window (find-window window)) + (source (elt data 0))) + (when our-window + (if (= source 2) ;request is from a pager + (focus-all our-window) + (maybe-raise-window our-window))))) + (:_NET_CLOSE_WINDOW + (let ((our-window (find-window window))) + (when our-window + (delete-window our-window)))) + (:_NET_WM_STATE + (let ((our-window (find-window window))) + (when our-window + (let ((action (elt data 0)) + (p1 (elt data 1)) + (p2 (elt data 2))) + (dolist (p (list p1 p2)) + (unless (= p 0) + (case (xlib:atom-name *display* p) + (:_NET_WM_STATE_FULLSCREEN + (update-fullscreen our-window action))))))))) + (:_NET_MOVERESIZE_WINDOW + (let ((our-window (find-window window))) + (when our-window + (let ((x (elt data 1)) + (y (elt data 2))) + (dformat 3 "!!! Data: ~S~%" data) + (handle-window-move our-window x y :relative :root))))) + (t + (dformat 2 "ignored message~%")))) + +(defun focus-all (win) + "Focus the window, frame, group and screen belonging to WIN. Raise +the window in it's frame." + (when (and win (window-frame win)) + (unmap-message-window (window-screen win)) + (switch-to-screen (window-screen win)) + (let ((frame (window-frame win)) + (group (window-group win))) + (switch-to-group group) + (frame-raise-window group frame win)))) + +;; Handling event :KEY-PRESS +;; (:DISPLAY # :EVENT-KEY :KEY-PRESS :EVENT-CODE 2 :SEND-EVENT-P NIL :CODE 45 :SEQUENCE 1419 :TIME 98761213 :ROOT # :WINDOW # :EVENT-WINDOW # :CHILD +;; # :ROOT-X 754 :ROOT-Y 223 :X 753 :Y 222 :STATE 4 :SAME-SCREEN-P T) +;; H + +(defun handle-event (&rest event-slots &key display event-key &allow-other-keys) + (declare (ignore display)) + (dformat 1 ">>> ~S~%" event-key) + (let ((eventfn (gethash event-key *event-fn-table*))) + (when eventfn + (handler-case + (progn + ;; This is not the stumpwm top level, but if the restart + ;; is in the top level then it seems the event being + ;; processed isn't popped off the stack and is immediately + ;; reprocessed after restarting to the top level. So fake + ;; it, and put the restart here. + (with-simple-restart (top-level "Return to stumpwm's top level") + (apply eventfn event-slots)) + (xlib:display-finish-output *display*)) + ((or xlib:window-error xlib:drawable-error) (c) + ;; Asynchronous errors are handled in the error + ;; handler. Synchronous errors like trying to get the window + ;; hints on a deleted window are caught and ignored here. We + ;; do this inside the event handler so that the event is + ;; handled. If we catch it higher up the event will not be + ;; flushed from the queue and we'll get ourselves into an + ;; infinite loop. + (dformat 4 "ignore synchronous ~a~%" c)))) + (dformat 2 "<<< ~S~%" event-key) + t)) + +;;; handler.lisp ends here diff --git a/interaction.lisp b/interaction.lisp new file mode 100644 index 0000000..9e2e25c --- /dev/null +++ b/interaction.lisp @@ -0,0 +1,442 @@ +;; Copyright (C) 2003, 2008 * +;; +;; This file is part of stumpwm. +;; +;; stumpwm is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; stumpwm is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA +;; +;; Commentary: +;; +;; Commands for (a) sending input to stumpwm and (b) getting messages +;; back; extracted from core.lisp. +;; +;; * core.lisp Copyright (C) 2003 Shawn Betts +;; +;; Code: + +(in-package :stumpwm) + +(export '(get-x-selection + echo-string + message + err + set-x-selection)) + + +;;; ------------------------------------------------------------------ +;;; Setting up the message window +;;; ------------------------------------------------------------------ + +(defun internal-window-p (screen win) + "Return t if win is a window used by stumpwm" + (or (xlib:window-equal (screen-message-window screen) win) + (xlib:window-equal (screen-input-window screen) win) + (xlib:window-equal (screen-focus-window screen) win) + (xlib:window-equal (screen-key-window screen) win))) + +(defun setup-message-window (screen lines width) + (let ((height (* lines + (+ (xlib:font-ascent (screen-font screen)) + (xlib:font-descent (screen-font screen))))) + (win (screen-message-window screen))) + ;; Now that we know the dimensions, raise and resize it. + (xlib:with-state (win) + (setf (xlib:drawable-height win) height + (xlib:drawable-width win) (+ width (* *message-window-padding* 2)) + (xlib:window-priority win) :above) + (setup-win-gravity screen win *message-window-gravity*)) + (xlib:map-window win) + ;; Clear the window + (xlib:clear-area win) + (incf (screen-ignore-msg-expose screen)) + ;; Have to flush this or the window might get cleared + ;; after we've already started drawing it. + (xlib:display-finish-output *display*))) + +(defun invert-rect (screen win x y width height) + "invert the color in the rectangular area. Used for highlighting text." + (let ((gcontext (xlib:create-gcontext :drawable win + :foreground (screen-fg-color screen) + :function boole-xor))) + (xlib:draw-rectangle win gcontext x y width height t) + (setf (xlib:gcontext-foreground gcontext) (screen-bg-color screen)) + (xlib:draw-rectangle win gcontext x y width height t))) + +(defun unmap-message-window (screen) + "Unmap the screen's message window, if it is mapped." + (unless (eq (xlib:window-map-state (screen-message-window screen)) :unmapped) + (xlib:unmap-window (screen-message-window screen)))) + +(defun unmap-all-message-windows () + (mapc #'unmap-message-window *screen-list*) + (when (timer-p *message-window-timer*) + (cancel-timer *message-window-timer*) + (setf *message-window-timer* nil))) + +;;; ------------------------------------------------------------------ +;;; Echoing things +;;; ------------------------------------------------------------------ + +(defun err (fmt &rest args) + "run FMT and ARGS through format and echo the result to the +current screen along with a backtrace. For careful study, the +message does not time out." + (let ((*suppress-echo-timeout* t)) + (echo-string (current-screen) + (concat (apply 'format nil fmt args) + (backtrace-string))))) + +(defun echo-in-window (win font fg bg string) + (let* ((height (font-height font)) + (gcontext (xlib:create-gcontext :drawable win + :font font + :foreground fg + :background bg)) + (width (xlib:text-width font string))) + (xlib:with-state (win) + (setf (xlib:drawable-height win) height + (xlib:drawable-width win) width)) + (xlib:clear-area win) + (xlib:display-finish-output *display*) + (xlib:draw-image-glyphs win gcontext 0 (xlib:font-ascent font) string))) + +(defun push-last-message (screen strings highlights) + ;; only push unique messages + (unless *record-last-msg-override* + (push strings (screen-last-msg screen)) + (push highlights (screen-last-msg-highlights screen)) + ;; crop for size + (when (>= (length (screen-last-msg screen)) *max-last-message-size*) + (setf (screen-last-msg screen) (butlast (screen-last-msg screen))) + (setf (screen-last-msg-highlights screen) (butlast (screen-last-msg-highlights screen)))))) + +(defun redraw-current-message (screen) + (let ((*record-last-msg-override* t) + (*ignore-echo-timeout* t)) + (dformat 5 "Redrawing message window!~%") + (apply 'echo-string-list screen (screen-current-msg screen) (screen-current-msg-highlights screen)))) + +(defun echo-nth-last-message (screen n) + (let ((*record-last-msg-override* t)) + (apply 'echo-string-list screen (nth n (screen-last-msg screen)) (nth n (screen-last-msg-highlights screen))))) + +(defun echo-string-list (screen strings &rest highlights) + "Draw each string in l in the screen's message window. HIGHLIGHT is + the nth entry to highlight." + (unless *executing-stumpwm-command* + (let ((width (render-strings screen (screen-message-cc screen) *message-window-padding* 0 strings '() nil))) + (setup-message-window screen (length strings) width) + (render-strings screen (screen-message-cc screen) *message-window-padding* 0 strings highlights)) + (setf (screen-current-msg screen) + strings + (screen-current-msg-highlights screen) + highlights)) + (push-last-message screen strings highlights) + (xlib:display-finish-output *display*) + ;; Set a timer to hide the message after a number of seconds + (if *suppress-echo-timeout* + ;; any left over timers need to be canceled. + (when (timer-p *message-window-timer*) + (cancel-timer *message-window-timer*) + (setf *message-window-timer* nil)) + (reset-message-window-timer)) + (apply 'run-hook-with-args *message-hook* strings)) + +(defun echo-string (screen msg) + "Display @var{string} in the message bar on @var{screen}. You almost always want to use @command{message}." + (echo-string-list screen (split-string msg (string #\Newline)))) + +(defun message (fmt &rest args) + "run FMT and ARGS through `format' and echo the result to the current screen." + (echo-string (current-screen) (apply 'format nil fmt args))) + +(defun message-no-timeout (fmt &rest args) + "Like message, but the window doesn't disappear after a few seconds." + (let ((*suppress-echo-timeout* t)) + (apply 'message fmt args))) + +(defun find-message-window-screen (win) + "Return the screen, if any, that message window WIN belongs." + (dolist (screen *screen-list*) + (when (xlib:window-equal (screen-message-window screen) win) + (return screen)))) + +(defun columnize (list columns &key col-aligns (pad 1) (char #\Space) (align :left)) + ;; only somewhat nasty + (let* ((rows (truncate (length list) columns)) + (data (loop for i from 0 below (length list) by rows + collect (subseq list i (min (+ i rows) (length list))))) + (max (mapcar (lambda (col) + (reduce 'max col :key 'length :initial-value 0)) + data)) + (padstr (make-string pad :initial-element char))) + (apply 'mapcar 'concat + ;; normalize width + (loop + for i in data + for j in max + for c from 0 + collect (loop + for k from 0 below rows + for s = (or (nth k i) "") + for len = (make-string (- j (length s)) + :initial-element char) + collect (ecase (or (nth c col-aligns) align) + (:left (format nil "~a~a~a" (if (= c 0) "" padstr) s len)) + (:right (format nil "~a~a~a" (if (= c 0) "" padstr) len s)))))))) + +(defun display-keybinding (kmap-var) + (let* ((screen (current-screen)) + (data (mapcar-hash (lambda (k v) (format nil "^5*~5a^n ~a" (print-key k) v)) (symbol-value kmap-var))) + (cols (ceiling (length data) + (truncate (- (head-height (current-head)) (* 2 (screen-msg-border-width screen))) + (font-height (screen-font screen)))))) + (message-no-timeout "Prefix: ~{~a~^ | ~}~%~{~a~^~%~}" + (mapcar 'print-key-seq (search-kmap kmap-var *top-map*)) + (columnize data cols)))) + +(defun window-send-string (window string) + "Send the string of characters to the window as if they'd been typed." + (when window + (map nil (lambda (ch) + ;; exploit the fact that keysyms for ascii characters + ;; are the same as their ascii value. + (let ((sym (cond ((<= 32 (char-code ch) 127) + (char-code ch)) + ((char= ch #\Tab) + (stumpwm-name->keysym "TAB")) + ((char= ch #\Newline) + (stumpwm-name->keysym "RET")) + (t nil)))) + (when sym + (send-fake-key window + (make-key :keysym sym))))) + string))) + +;;; ------------------------------------------------------------------ +;;; Keyboard +;;; ------------------------------------------------------------------ + +(defun key-to-keycode+state (key) + (let ((code (xlib:keysym->keycodes *display* (key-keysym key)))) + (cond ((eq (xlib:keycode->keysym *display* code 0) (key-keysym key)) + (values code (x11-mods key))) + ((eq (xlib:keycode->keysym *display* code 1) (key-keysym key)) + (values code (apply 'xlib:make-state-mask + (cons :shift (xlib:make-state-keys (x11-mods key)))))) + (t + ;; just warn them and go ahead as scheduled + (warn "Don't know how to encode ~s" key) + (values code (x11-mods key)))))) + +(defun send-fake-key (win key) + "Send a fake key event to win. ch is the character and mods is a +list of modifier symbols." + (multiple-value-bind (code state) (key-to-keycode+state key) + (xlib:send-event (window-xwin win) :key-press (xlib:make-event-mask :key-press) + :display *display* + :root (screen-root (window-screen win)) + ;; Apparently we need these in here, though they + ;; make no sense for a key event. + :x 0 :y 0 :root-x 0 :root-y 0 + :window (window-xwin win) :event-window (window-xwin win) + :code code + :state state))) + +(defun grab-keyboard (screen) + (let ((ret (xlib:grab-keyboard (screen-root screen) :owner-p nil + :sync-keyboard-p nil :sync-pointer-p nil))) + (dformat 5 "vvv Grab keyboard: ~s~%" ret) + ret)) + +(defun ungrab-keyboard () + (let ((ret (xlib:ungrab-keyboard *display*))) + (dformat 5 "^^^ Ungrab keyboard: ~s~%" ret) + ret)) + +(defun read-from-keymap (kmap &optional update-fn) + "Read a sequence of keys from the user, guided by the keymap, +KMAP and return the binding or nil if the user hit an unbound sequence. + +The Caller is responsible for setting up the input focus." + (let* ((code-state (read-key-no-modifiers)) + (code (car code-state)) + (state (cdr code-state))) + (handle-keymap kmap code state nil nil update-fn))) + +;;; ------------------------------------------------------------------ +;;; Rat +;;; ------------------------------------------------------------------ + +(defun send-fake-click (win button) + "Send a fake key event to win. ch is the character and mods is a +list of modifier symbols." + ;; I don't know why this doesn't work. Sadly CLX doesn't have the + ;; XTest extension like xlib does. With it this would be 2 lines. + (multiple-value-bind (x y) (xlib:query-pointer (window-xwin win)) + (multiple-value-bind (rx ry) (xlib:query-pointer (screen-root (window-screen win))) + (xlib:send-event (window-xwin win) :button-press (xlib:make-event-mask :button-press) + :display *display* + :root (screen-root (window-screen win)) + :window (window-xwin win) :event-window (window-xwin win) + :code button + :state 0 + :x x :y y :root-x rx :root-y ry + :same-screen-p t) + (xlib:send-event (window-xwin win) :button-release (xlib:make-event-mask :button-release) + :display *display* + :root (screen-root (window-screen win)) + :window (window-xwin win) :event-window (window-xwin win) + :code button + :state #x100 + :x x :y y :root-x rx :root-y ry + :same-screen-p t)))) + +(defun grab-pointer (screen) + "Grab the pointer and set the pointer shape." + (let* ((white (xlib:make-color :red 1.0 :green 1.0 :blue 1.0)) + (black (xlib:make-color :red 0.0 :green 0.0 :blue 0.0)) + (cursor-font (xlib:open-font *display* "cursor")) + (cursor (xlib:create-glyph-cursor :source-font cursor-font + :source-char 64 + :mask-font cursor-font + :mask-char 65 + :foreground black + :background white))) + (xlib:grab-pointer (screen-root screen) nil :owner-p nil + :cursor cursor))) + +(defun ungrab-pointer () + "Remove the grab on the cursor and restore the cursor shape." + (xlib:ungrab-pointer *display*) + (xlib:display-finish-output *display*)) + +(defun warp-pointer (screen x y) + "Move the pointer to the specified location." + (let ((root (screen-root screen))) + (xlib:warp-pointer root x y))) + +(defun warp-pointer-relative (dx dy) + "Move the pointer by DX and DY relative to the current location." + (xlib:warp-pointer-relative *display* dx dy)) + +(defun banish-pointer (&optional (where *banish-pointer-to*)) + "Move the pointer to the lower right corner of the head, or + WHEREever (one of :screen :head :frame or :window)" + (let* ((screen (current-screen)) + (group (current-group)) + (head (current-head)) + (frame (tile-group-current-frame group)) + (window (frame-window frame)) + (x (1- (+ (frame-x frame) (frame-width frame)))) + (y (1- (+ (frame-display-y group frame) (frame-display-height group frame))))) + (ecase where + (:screen + (setf x (1- (+ (screen-x screen) (screen-width screen))) + y (1- (+ (screen-y screen) (screen-height screen))))) + (:head + (setf x (1- (+ (head-x head) (head-width head))) + y (1- (+ (head-y head) (head-height head))))) + (:frame) + (:window + (when window + (let ((win (window-parent window))) + (setf x (1- (+ (xlib:drawable-x win) (xlib:drawable-width win))) + y (1- (+ (xlib:drawable-y win) (xlib:drawable-height win)))))))) + (warp-pointer (group-screen group) x y))) + +;;; ------------------------------------------------------------------ +;;; X selection +;;; ------------------------------------------------------------------ + +(defun export-selection () + (let* ((screen (current-screen)) + (selwin (screen-focus-window (current-screen))) + (root (screen-root screen))) + (xlib:set-selection-owner *display* :primary selwin) + (unless (eq (xlib:selection-owner *display* :primary) selwin) + (error "Can't set selection owner")) + ;; also set the cut buffer for completeness + (xlib:change-property root :cut-buffer0 *x-selection* + :string 8 :transform #'xlib:char->card8 + :mode :replace))) + +(defun set-x-selection (text) + "Set the X11 selection string to @var{string}." + (setf *x-selection* text) + (export-selection)) + +(defun send-selection (requestor property selection target time) + (dformat 1 "send-selection ~s ~s ~s ~s ~s~%" requestor property selection target time) + (cond + ;; they're requesting what targets are available + ((eq target :targets) + (xlib:change-property requestor property + (list :targets :string) + target 8 :mode :replace)) + ;; send them a string + ((find target '(:string )) + (xlib:change-property requestor property *x-selection* + :string 8 :mode :replace + :transform #'xlib:char->card8)) + ;; we don't know how to handle anything else + (t + (setf property nil))) + (xlib:send-event requestor :selection-notify nil + :display *display* + :window requestor + :selection selection + :property property + :target target + :time time) + (xlib:display-finish-output *display*)) + +(defun get-x-selection (&optional timeout) + "Return the x selection no matter what client own it." + (labels ((wait-for-selection + (&rest event-slots &key display event-key &allow-other-keys) + (declare (ignore display)) + (when (eq event-key :selection-notify) + (destructuring-bind + (&key window property &allow-other-keys) event-slots + (if property + (xlib:get-property window property + :type :string + :result-type 'string + :transform #'xlib:card8->char + :delete-p t) + ""))))) + (if *x-selection* + *x-selection* + (progn + (xlib:convert-selection :primary + :string (screen-input-window + (current-screen)) + :stumpwm-selection) + ;; Note: this may spend longer than timeout in this loop but + ;; it will eventually return. + (let ((time (get-internal-real-time))) + (loop for ret = + (xlib:process-event *display* + :handler #'wait-for-selection + :timeout timeout :discard-p nil) + when (or ret + (> (/ (- time (get-internal-real-time)) + internal-time-units-per-second) + timeout)) + ;; make sure we return a string + return (or ret ""))))))) + +;;; interaction.lisp ends here diff --git a/maps.lisp b/maps.lisp new file mode 100644 index 0000000..d461406 --- /dev/null +++ b/maps.lisp @@ -0,0 +1,259 @@ +;; Copyright (C) 2003, 2008 * +;; +;; This file is part of stumpwm. +;; +;; stumpwm is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; stumpwm is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA +;; +;; Commentary: +;; +;; Keymap code from user.lisp and core.lisp +;; +;; * user.lisp and core.lisp Copyright (C) 2003 Shawn Betts +;; +;; Code: + +;;; Misc + +(in-package :stumpwm) + +(export '(*top-map* + *top-map-list* + *root-map* + *help-map* + *groups-map* + *menu-map* + set-prefix-key)) + +;;; top + +;; Do it this way so its easier to wipe the map and get a clean one. +(when (null *top-map*) + (setf *top-map* + (let ((m (make-sparse-keymap))) + (define-key m (kbd "C-t") '*root-map*) + m))) + +;;; Top map push/popping + +(defvar *top-map-list* nil) + +(defun push-top-map (new-top) + (push *top-map* *top-map-list*) + (setf *top-map* new-top) + (sync-keys)) + +(defun pop-top-map () + (when *top-map-list* + (setf *top-map* (pop *top-map-list*)) + (sync-keys) + t)) + +;;; root + +(defvar *root-map* nil + "This is the keymap by default bound to @kbd{C-t}. It is known as the @dfn{prefix map}.") + +;; Do it this way so its easier to wipe the map and get a clean one. +(when (null *root-map*) + (setf *root-map* + (let ((m (make-sparse-keymap))) + (define-key m (kbd "c") "exec xterm") + (define-key m (kbd "C-c") "exec xterm") + (define-key m (kbd "e") "emacs") + (define-key m (kbd "C-e") "emacs") + (define-key m (kbd "n") "pull-hidden-next") + (define-key m (kbd "C-n") "pull-hidden-next") + (define-key m (kbd "M-n") "next") + (define-key m (kbd "C-M-n") "next-in-frame") + (define-key m (kbd "SPC") "pull-hidden-next") + (define-key m (kbd "C-SPC") "pull-hidden-next") + (define-key m (kbd "p") "pull-hidden-previous") + (define-key m (kbd "C-p") "pull-hidden-previous") + (define-key m (kbd "M-p") "prev") + (define-key m (kbd "C-M-p") "prev-in-frame") + (define-key m (kbd "w") "windows") + (define-key m (kbd "C-w") "windows") + (define-key m (kbd "W") "place-existing-windows") + (define-key m (kbd "k") "delete") + (define-key m (kbd "C-k") "delete") + (define-key m (kbd "K") "kill") + (define-key m (kbd "b") "banish") + (define-key m (kbd "C-b") "banish") + (define-key m (kbd "a") "time") + (define-key m (kbd "C-a") "time") + (define-key m (kbd "'") "select") + (define-key m (kbd "\"") "windowlist") + (define-key m (kbd "C-t") "pull-hidden-other") + (define-key m (kbd "M-t") "other-in-frame") + (define-key m (kbd "!") "exec") + (define-key m (kbd "C-g") "abort") + (define-key m (kbd "0") "pull 0") + (define-key m (kbd "1") "pull 1") + (define-key m (kbd "2") "pull 2") + (define-key m (kbd "3") "pull 3") + (define-key m (kbd "4") "pull 4") + (define-key m (kbd "5") "pull 5") + (define-key m (kbd "6") "pull 6") + (define-key m (kbd "7") "pull 7") + (define-key m (kbd "8") "pull 8") + (define-key m (kbd "9") "pull 9") + (define-key m (kbd "R") "remove") + (define-key m (kbd "s") "vsplit") + (define-key m (kbd "S") "hsplit") + (define-key m (kbd "r") "iresize") + (define-key m (kbd "o") "fnext") + (define-key m (kbd "TAB") "fnext") + (define-key m (kbd "f") "fselect") + (define-key m (kbd "F") "curframe") + (define-key m (kbd "t") "meta C-t") + (define-key m (kbd "C-N") "number") + (define-key m (kbd ";") "colon") + (define-key m (kbd ":") "eval") + (define-key m (kbd "C-h") "help") + (define-key m (kbd "-") "fclear") + (define-key m (kbd "Q") "only") + (define-key m (kbd "Up") "move-focus up") + (define-key m (kbd "Down") "move-focus down") + (define-key m (kbd "Left") "move-focus left") + (define-key m (kbd "Right") "move-focus right") + (define-key m (kbd "M-Up") "move-window up") + (define-key m (kbd "M-Down") "move-window down") + (define-key m (kbd "M-Left") "move-window left") + (define-key m (kbd "M-Right") "move-window right") + (define-key m (kbd "v") "version") + (define-key m (kbd "#") "mark") + (define-key m (kbd "m") "lastmsg") + (define-key m (kbd "C-m") "lastmsg") + (define-key m (kbd "G") "vgroups") + (define-key m (kbd "g") '*groups-map*) + (define-key m (kbd "F1") "gselect 1") + (define-key m (kbd "F2") "gselect 2") + (define-key m (kbd "F3") "gselect 3") + (define-key m (kbd "F4") "gselect 4") + (define-key m (kbd "F5") "gselect 5") + (define-key m (kbd "F6") "gselect 6") + (define-key m (kbd "F7") "gselect 7") + (define-key m (kbd "F8") "gselect 8") + (define-key m (kbd "F9") "gselect 9") + (define-key m (kbd "F10") "gselect 10") + (define-key m (kbd "F11") "fullscreen") + (define-key m (kbd "?") "help") + (define-key m (kbd "+") "balance-frames") + (define-key m (kbd "A") "title") + (define-key m (kbd "h") '*help-map*) + m))) + +;;; help + +(defvar *help-map* nil + "Help related bindings hang from this keymap") + +(when (null *help-map*) + (setf *help-map* + (let ((m (make-sparse-keymap))) + (define-key m (kbd "v") "describe-variable") + (define-key m (kbd "f") "describe-function") + (define-key m (kbd "k") "describe-key") + (define-key m (kbd "w") "where-is") + m))) + +;;; groups + +(defvar *groups-map* nil + "The keymap that group related key bindings sit on. It is bound to @kbd{C-t g} by default.") + +(when (null *groups-map*) + (setf *groups-map* + (let ((m (make-sparse-keymap))) + (define-key m (kbd "g") "groups") + (define-key m (kbd "c") "gnew") + (define-key m (kbd "n") "gnext") + (define-key m (kbd "C-n") "gnext") + (define-key m (kbd "SPC") "gnext") + (define-key m (kbd "C-SPC") "gnext") + (define-key m (kbd "p") "gprev") + (define-key m (kbd "C-p") "gprev") + (define-key m (kbd "o") "gother") + (define-key m (kbd "'") "gselect") + (define-key m (kbd "m") "gmove") + (define-key m (kbd "M") "gmove-marked") + (define-key m (kbd "k") "gkill") + (define-key m (kbd "A") "grename") + (define-key m (kbd "r") "grename") + (define-key m (kbd "1") "gselect 1") + (define-key m (kbd "2") "gselect 2") + (define-key m (kbd "3") "gselect 3") + (define-key m (kbd "4") "gselect 4") + (define-key m (kbd "5") "gselect 5") + (define-key m (kbd "6") "gselect 6") + (define-key m (kbd "7") "gselect 7") + (define-key m (kbd "8") "gselect 8") + (define-key m (kbd "9") "gselect 9") + (define-key m (kbd "0") "gselect 10") + m))) + +;;; menu + +(defvar *menu-map* nil + "The keymap used by the interactive menu.") + +(when (null *menu-map*) + (setf *menu-map* + (let ((m (make-sparse-keymap))) + (define-key m (kbd "C-p") 'menu-up) + (define-key m (kbd "Up") 'menu-up) + (define-key m (kbd "k") 'menu-up) + + (define-key m (kbd "C-n") 'menu-down) + (define-key m (kbd "Down") 'menu-down) + (define-key m (kbd "j") 'menu-down) + (define-key m (kbd "C-g") 'menu-abort) + (define-key m (kbd "ESC") 'menu-abort) + (define-key m (kbd "RET") 'menu-finish) + m))) + +;;; sending and setting keys + +(defun send-meta-key (screen key) + "Send the prefix key" + (when (screen-current-window screen) + (send-fake-key (screen-current-window screen) key))) + +(defun set-prefix-key (key) + "Change the stumpwm prefix key to KEY. address@hidden +\(stumpwm:set-prefix-key (stumpwm:kbd \"C-M-H-s-z\")) address@hidden example + +This will change the prefix key to @key{Control} + @key{Meta} + @key{Hyper} + @key{Super} + +the @key{z} key. By most standards, a terrible prefix key but it makes a +great example." + (check-type key key) + (let (prefix) + (dolist (i (lookup-command *top-map* '*root-map*)) + (setf prefix i) + (undefine-key *top-map* i)) + (define-key *top-map* key '*root-map*) + (let* ((meta (make-key :keysym (key-keysym key))) + (old-cmd (concatenate 'string "meta " (print-key prefix))) + (cmd (concatenate 'string "meta " (print-key key)))) + (dolist (i (lookup-command *root-map* old-cmd)) + (undefine-key *root-map* i)) + (define-key *root-map* meta cmd)) + (define-key *root-map* key "other") + (sync-keys))) + +;;; maps.lisp ends here diff --git a/menu.lisp b/menu.lisp new file mode 100644 index 0000000..c12c93a --- /dev/null +++ b/menu.lisp @@ -0,0 +1,134 @@ +;; Copyright (C) 2003, 2008 * +;; +;; This file is part of stumpwm. +;; +;; stumpwm is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; stumpwm is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA +;; +;; Commentary: +;; +;; Menu-related commands extracted from user.lisp. +;; +;; * user.lisp Copyright (C) 2003 Shawn Betts +;; +;; Code: + +(in-package :stumpwm) + +(export '(restarts-menu + select-from-menu)) + +(defun restarts-menu (err) + "Display a menu with the active restarts and let the user pick +one. Error is the error being recovered from. If the user aborts the +menu, the error is re-signalled." + (let ((restart + (select-from-menu (current-screen) + (mapcar + (lambda (r) + (list (format + nil "[~a] ~a" + (restart-name r) + (substitute #\Space + #\Newline + (write-to-string r + :escape + nil))) + r)) + ;; a crusty way to get only + ;; the restarts from + ;; stumpwm's top-level + ;; restart inward. + (reverse (member 'top-level + (reverse (compute-restarts)) + :key 'restart-name))) + (format nil "Error: ~a" + (substitute #\Space + #\Newline + (write-to-string + err + :escape nil)))))) + (when restart + (invoke-restart (second restart))))) + +;;; interactive menu + +(defstruct menu-state + table prompt selected) + +(defun bound-check-menu (menu) + (setf (menu-state-selected menu) + (cond ((< (menu-state-selected menu) 0) + (1- (length (menu-state-table menu)))) + ((>= (menu-state-selected menu) + (length (menu-state-table menu))) + 0) + (t (menu-state-selected menu))))) + +(defun menu-up (menu) + (decf (menu-state-selected menu)) + (bound-check-menu menu)) + +(defun menu-down (menu) + (incf (menu-state-selected menu)) + (bound-check-menu menu)) + +(defun menu-finish (menu) + (throw :menu-quit (nth (menu-state-selected menu) + (menu-state-table menu)))) + +(defun menu-abort (menu) + (declare (ignore menu)) + (throw :menu-quit nil)) + +(defun select-from-menu (screen table &optional prompt (initial-selection 0)) + "Prompt the user to select from a menu on SCREEN. TABLE can be +a list of values or an alist. If it's an alist, the CAR of each +element is displayed in the menu. What is displayed as menu items +must be strings. Returns the selected element in TABLE or nil if aborted. + +See *menu-map* for menu bindings." + (check-type screen screen) + (check-type table list) + (check-type prompt (or null string)) + (check-type initial-selection integer) + (let* ((menu (make-menu-state + :table table + :prompt prompt + :selected initial-selection)) + (menu-options (mapcar (lambda (elt) + (if (listp elt) + (first elt) + elt)) + table)) + (menu-text (if prompt + (cons prompt menu-options) + menu-options)) + (*record-last-msg-override* t) + (*suppress-echo-timeout* t)) + (bound-check-menu menu) + (catch :menu-quit + (unwind-protect + (with-focus (screen-key-window screen) + (loop + (echo-string-list screen menu-text + (+ (menu-state-selected menu) + (if prompt 1 0))) + (let ((action (read-from-keymap *menu-map*))) + (when action + (funcall action menu))))) + (unmap-all-message-windows))))) + +;;; menu.lisp ends here diff --git a/mode-line.lisp b/mode-line.lisp index 03d1274..96be12a 100644 --- a/mode-line.lisp +++ b/mode-line.lisp @@ -497,6 +497,4 @@ timer.") (when (head-mode-line head) (toggle-mode-line screen head)))) -(defcommand mode-line () () - "A command to toggle the mode line visibility." - (toggle-mode-line (current-screen) (current-head))) +;;; mode-line.lisp ends here diff --git a/netwm.lisp b/netwm.lisp new file mode 100644 index 0000000..cedb6c9 --- /dev/null +++ b/netwm.lisp @@ -0,0 +1,184 @@ +;; Copyright (C) 2003, 2008 * +;; +;; This file is part of stumpwm. +;; +;; stumpwm is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; stumpwm is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA +;; +;; Commentary: +;; +;; netwm-related commands, extracted from core.lisp. +;; +;; * core.lisp Copyright (C) 2003 Shawn Betts +;; +;; Code: + +(in-package :stumpwm) + +(defparameter +netwm-supported+ + '(:_NET_SUPPORTING_WM_CHECK + :_NET_NUMBER_OF_DESKTOPS + :_NET_DESKTOP_GEOMETRY + :_NET_DESKTOP_VIEWPORT + :_NET_CURRENT_DESKTOP + :_NET_WM_WINDOW_TYPE + :_NET_WM_STATE + :_NET_WM_STATE_MODAL + :_NET_WM_ALLOWED_ACTIONS + :_NET_WM_STATE_FULLSCREEN + :_NET_WM_STATE_HIDDEN + :_NET_WM_FULL_WINDOW_PLACEMENT + :_NET_CLOSE_WINDOW + :_NET_CLIENT_LIST + :_NET_CLIENT_LIST_STACKING + :_NET_ACTIVE_WINDOW + :_KDE_NET_SYSTEM_TRAY_WINDOW_FOR) + "Supported NETWM properties. +Window types are in +WINDOW-TYPES+.") + +(defparameter +netwm-allowed-actions+ + '(:_NET_WM_ACTION_CHANGE_DESKTOP + :_NET_WM_ACTION_FULLSCREEN + :_NET_WM_ACTION_CLOSE) + "Allowed NETWM actions for managed windows") + +(defparameter +netwm-window-types+ + '( + ;; (:_NET_WM_WINDOW_TYPE_DESKTOP . :desktop) + (:_NET_WM_WINDOW_TYPE_DOCK . :dock) + ;; (:_NET_WM_WINDOW_TYPE_TOOLBAR . :toolbar) + ;; (:_NET_WM_WINDOW_TYPE_MENU . :menu) + ;; (:_NET_WM_WINDOW_TYPE_UTILITY . :utility) + ;; (:_NET_WM_WINDOW_TYPE_SPLASH . :splash) + (:_NET_WM_WINDOW_TYPE_DIALOG . :dialog) + (:_NET_WM_WINDOW_TYPE_NORMAL . :normal)) + "Alist mapping NETWM window types to keywords. +Include only those we are ready to support.") + +(defun netwm-group-id (group) + "netwm specifies that desktop/group numbers are contiguous and start +at 0. Return a netwm compliant group id." + (let ((screen (group-screen group))) + (position group (sort-groups screen)))) + +(defun netwm-update-groups (screen) + "update all windows to reflect a change in the group list." + ;; FIXME: This could be optimized only to update windows when there + ;; is a need. + (loop for i from 0 + for group in (sort-groups screen) + do (dolist (w (group-windows group)) + (xlib:change-property (window-xwin w) :_NET_WM_DESKTOP + (list i) + :cardinal 32)))) + +(defun netwm-set-group-properties (screen) + "Set NETWM properties regarding groups of SCREEN. +Groups are known as \"virtual desktops\" in the NETWM standard." + (let ((root (screen-root screen))) + ;; _NET_NUMBER_OF_DESKTOPS + (xlib:change-property root :_NET_NUMBER_OF_DESKTOPS + (list (length (screen-groups screen))) + :cardinal 32) + (unless *initializing* + ;; _NET_CURRENT_DESKTOP + (xlib:change-property root :_NET_CURRENT_DESKTOP + (list (netwm-group-id (screen-current-group screen))) + :cardinal 32)) + ;; _NET_DESKTOP_NAMES + (xlib:change-property root :_NET_DESKTOP_NAMES + (let ((names (mapcan + (lambda (group) + (list (string-to-utf8 (group-name group)) + '(0))) + (sort-groups screen)))) + (apply #'concatenate 'list names)) + :UTF8_STRING 8))) + +(defun netwm-remove-window (window) + (xlib:delete-property (window-xwin window) :_NET_WM_DESKTOP)) + +(defun netwm-update-client-list-stacking (screen) + (unless *initializing* + (xlib:change-property (screen-root screen) + :_NET_CLIENT_LIST_STACKING + ;; Order is bottom to top. + (reverse (mapcar 'window-xwin (all-windows))) + :window 32 + :transform #'xlib:drawable-id + :mode :replace))) + +(defun netwm-update-client-list (screen) + (xlib:change-property (screen-root screen) + :_NET_CLIENT_LIST + (screen-mapped-windows screen) + :window 32 + :transform #'xlib:drawable-id + :mode :replace) + (netwm-update-client-list-stacking screen)) + +(defun netwm-set-properties (screen focus-window) + "Set NETWM properties on the root window of the specified screen. +FOCUS-WINDOW is an extra window used for _NET_SUPPORTING_WM_CHECK." + (let* ((screen-number (screen-number screen)) + (root (xlib:screen-root screen-number))) + ;; _NET_SUPPORTED + (xlib:change-property root :_NET_SUPPORTED + (mapcar (lambda (a) + (xlib:intern-atom *display* a)) + (append +netwm-supported+ + (mapcar #'car +netwm-window-types+))) + :atom 32) + + ;; _NET_SUPPORTING_WM_CHECK + (xlib:change-property root :_NET_SUPPORTING_WM_CHECK + (list focus-window) :window 32 + :transform #'xlib:drawable-id) + (xlib:change-property focus-window :_NET_SUPPORTING_WM_CHECK + (list focus-window) :window 32 + :transform #'xlib:drawable-id) + (xlib:change-property focus-window :_NET_WM_NAME + "stumpwm" + :string 8 :transform #'xlib:char->card8) + + ;; _NET_CLIENT_LIST + (xlib:change-property root :_NET_CLIENT_LIST + () :window 32 + :transform #'xlib:drawable-id) + + ;; _NET_DESKTOP_GEOMETRY + (xlib:change-property root :_NET_DESKTOP_GEOMETRY + (list (xlib:screen-width screen-number) + (xlib:screen-height screen-number)) + :cardinal 32) + + ;; _NET_DESKTOP_VIEWPORT + (xlib:change-property root :_NET_DESKTOP_VIEWPORT + (list 0 0) :cardinal 32) + + (netwm-set-group-properties screen))) + +(defun xwin-net-wm-name (win) + "Return the netwm wm name" + (let ((name (xlib:get-property win :_NET_WM_NAME))) + (when name + (utf8-to-string name)))) + +(defun xwin-name (win) + (or + (xwin-net-wm-name win) + (xlib:wm-name win))) + +;;; netwm.lisp ends here diff --git a/primitives.lisp b/primitives.lisp index ea788db..7f66fa4 100644 --- a/primitives.lisp +++ b/primitives.lisp @@ -220,46 +220,6 @@ the mode-line, the button clicked, and the x and y of the pointer.") (defvar *text-color* "white" "The color of message text.") -(defparameter +netwm-supported+ - '(:_NET_SUPPORTING_WM_CHECK - :_NET_NUMBER_OF_DESKTOPS - :_NET_DESKTOP_GEOMETRY - :_NET_DESKTOP_VIEWPORT - :_NET_CURRENT_DESKTOP - :_NET_WM_WINDOW_TYPE - :_NET_WM_STATE - :_NET_WM_STATE_MODAL - :_NET_WM_ALLOWED_ACTIONS - :_NET_WM_STATE_FULLSCREEN - :_NET_WM_STATE_HIDDEN - :_NET_WM_FULL_WINDOW_PLACEMENT - :_NET_CLOSE_WINDOW - :_NET_CLIENT_LIST - :_NET_CLIENT_LIST_STACKING - :_NET_ACTIVE_WINDOW - :_KDE_NET_SYSTEM_TRAY_WINDOW_FOR) - "Supported NETWM properties. -Window types are in +WINDOW-TYPES+.") - -(defparameter +netwm-allowed-actions+ - '(:_NET_WM_ACTION_CHANGE_DESKTOP - :_NET_WM_ACTION_FULLSCREEN - :_NET_WM_ACTION_CLOSE) - "Allowed NETWM actions for managed windows") - -(defparameter +netwm-window-types+ - '( - ;; (:_NET_WM_WINDOW_TYPE_DESKTOP . :desktop) - (:_NET_WM_WINDOW_TYPE_DOCK . :dock) - ;; (:_NET_WM_WINDOW_TYPE_TOOLBAR . :toolbar) - ;; (:_NET_WM_WINDOW_TYPE_MENU . :menu) - ;; (:_NET_WM_WINDOW_TYPE_UTILITY . :utility) - ;; (:_NET_WM_WINDOW_TYPE_SPLASH . :splash) - (:_NET_WM_WINDOW_TYPE_DIALOG . :dialog) - (:_NET_WM_WINDOW_TYPE_NORMAL . :normal)) - "Alist mapping NETWM window types to keywords. -Include only those we are ready to support.") - ;; Window states (defconstant +withdrawn-state+ 0) (defconstant +normal-state+ 1) @@ -712,15 +672,6 @@ Useful for re-using the &REST arg after removing some options." #-(or allegro clisp cmu gcl lispworks lucid sbcl scl) (error 'not-implemented :proc (list '(setf getenv) var))) -(defun pathname-is-executable-p (pathname) - "Return T if the pathname describes an executable file." - #+sbcl - (let ((filename (coerce (sb-int:unix-namestring pathname) 'base-string))) - (and (eq (sb-unix:unix-file-kind filename) :file) - (sb-unix:unix-access filename sb-unix:x_ok))) - ;; FIXME: add the code for clisp - #-sbcl t) - (defun probe-path (path) "Return the truename of a supplied path, or nil if it does not exist." (handler-case @@ -1100,4 +1051,5 @@ input focus is transfered to the window you click on.") (defvar *show-command-backtrace* nil "When this is T a backtrace is displayed with errors that occurred within an interactive call to a command.") - \ No newline at end of file + +;;; primitives.lisp ends here diff --git a/resize.lisp b/resize.lisp new file mode 100644 index 0000000..ae32c80 --- /dev/null +++ b/resize.lisp @@ -0,0 +1,86 @@ +;; Copyright (C) 2003, 2008 * +;; +;; This file is part of stumpwm. +;; +;; stumpwm is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; stumpwm is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA +;; +;; Commentary: +;; +;; Commands for resizing windows and frames; all code so far extracted +;; from user.lisp. +;; +;; * user.lisp Copyright (C) 2003 Shawn Betts +;; +;; Code: + +(in-package :stumpwm) + +;;; A resize minor mode. Something a bit better should probably be +;;; written. But it's an interesting way of doing it. + +(defvar *resize-backup* nil) + +(defvar *resize-increment* 10 + "Number of pixels to increment by when interactively resizing frames.") + +(defun set-resize-increment (val) + (setf *resize-increment* val) + (update-resize-map)) + +(defun update-resize-map () + (let ((m (or *resize-map* (setf *resize-map* (make-sparse-keymap))))) + (let ((i *resize-increment*)) + (labels ((dk (m k c) + (define-key m k (format nil c i)))) + (dk m (kbd "Up") "resize 0 -~D") + (dk m (kbd "C-p") "resize 0 -~D") + (dk m (kbd "p") "resize 0 -~D") + (dk m (kbd "k") "resize 0 -~D") + + (dk m (kbd "Down") "resize 0 ~D") + (dk m (kbd "C-n") "resize 0 ~D") + (dk m (kbd "n") "resize 0 ~D") + (dk m (kbd "j") "resize 0 ~D") + + (dk m (kbd "Left") "resize -~D 0") + (dk m (kbd "C-b") "resize -~D 0") + (dk m (kbd "b") "resize -~D 0") + (dk m (kbd "h") "resize -~D 0") + + (dk m (kbd "Right") "resize ~D 0") + (dk m (kbd "C-f") "resize ~D 0") + (dk m (kbd "f") "resize ~D 0") + (dk m (kbd "l") "resize ~D 0") + (define-key m (kbd "RET") "exit-iresize") + (define-key m (kbd "C-g") "abort-iresize") + (define-key m (kbd "ESC") "abort-iresize"))))) + +(update-resize-map) + +(defun resize-unhide () + (clear-frame-outlines (current-group)) + (when *resize-hides-windows* + (let ((group (current-group)) + (head (current-head))) + (dolist (f (head-frames group head)) + (sync-frame-windows group f)) + (dolist (w (reverse (head-windows group head))) + (setf (frame-window (window-frame w)) w) + (raise-window w)) + (when (current-window) + (focus-window (current-window)))))) + +;;; resize.lisp ends here diff --git a/stumpwm.asd b/stumpwm.asd index 3e863ad..cad8da8 100644 --- a/stumpwm.asd +++ b/stumpwm.asd @@ -30,13 +30,26 @@ (:file "keytrans") (:file "kmap") (:file "input") + (:file "netwm") + (:file "handler") + (:file "appearance") + (:file "interaction") (:file "core") + (:file "command") + (:file "maps") (:file "user") + (:file "types") + (:file "time") (:file "fdump") + (:file "group") + (:file "window") + (:file "frame") + (:file "resize") + (:file "menu") (:file "mode-line") - (:file "color") (:file "stumpwm") ;; keep this last so it always gets recompiled if ;; anything changes (:file "version"))) +;;; stumpwm.asd ends here diff --git a/time.lisp b/time.lisp new file mode 100644 index 0000000..7682788 --- /dev/null +++ b/time.lisp @@ -0,0 +1,165 @@ +;; Copyright (C) 2003, 2008 * +;; +;; This file is part of stumpwm. +;; +;; stumpwm is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; stumpwm is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA +;; +;; Commentary: +;; +;; Time-related commands from user.lisp. +;; +;; * user.lisp Copyright (C) 2003 Shawn Betts +;; +;; Code: + +(in-package :stumpwm) + +(defmacro time-lambda (used-var &body body) + `(lambda (sec min hour dom mon year dow dstp tz) + (declare (ignore ,@(set-difference + '(sec min hour dom mon year dow dstp tz) used-var))) + ,@body)) + +(defvar *month-names* + #("January" "February" "March" "April" "May" "June" "July" "August" + "September" "October" "November" "December")) + +(defvar *day-names* + #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) + +;; `date --help` with date_5.97 +;; `date --help` with date_5.97 +(defvar *format-time-string-alist* + `((#\% . ,(time-lambda () "%")) + (#\a . ,(time-lambda (dow) (subseq (aref *day-names* dow) 0 3))) + (#\A . ,(time-lambda (dow) (aref *day-names* dow))) + (#\b . ,(time-lambda (mon) (subseq (aref *month-names* (- mon 1)) 0 3))) + (#\B . ,(time-lambda (mon) (aref *month-names* (- mon 1)))) + (#\c . ,(time-lambda (dow mon dom hour min sec year) + (format nil "~A ~A ~2,'0D ~2,'0D:~2,'0D:~2,'0D ~D" + (subseq (aref *day-names* dow) 0 3) + (subseq (aref *month-names* (- mon 1)) 0 3) + dom hour min sec year))) + (#\C . ,(time-lambda (year) (subseq (format nil "~D" year) 0 2))) + (#\d . ,(time-lambda (dom) (format nil "~2,'0D" dom))) + (#\D . ,(time-lambda (mon dom year) + (format nil "~2,'0D/~2,'0D/~A" + mon dom (subseq + (format nil "~D" year) 2 4)))) + (#\e . ,(time-lambda (dom) (format nil "~2,' D" dom))) + (#\F . ,(time-lambda (year mon dom) + (format nil "~D-~2,'0D-~2,'0D" year mon dom))) + ;; %g last two digits of year of ISO week number (see %G) + ;; %G year of ISO week number (see %V); normally useful only with %V + (#\h . ,(time-lambda (mon) (subseq (aref *month-names* (- mon 1)) 0 3))) + (#\H . ,(time-lambda (hour) (format nil "~2,'0D" hour))) + (#\I . ,(time-lambda (hour) + (format nil "~2,'0D" + (if (> hour 12) (- hour 12) + (if (zerop hour) 12 hour))))) + ;; %j day of year (001..366) + (#\k . ,(time-lambda (hour) (format nil "~2,D" hour))) + (#\l . ,(time-lambda (hour) + (format nil "~2,D" + (if (> hour 12) (- hour 12) + (if (zerop hour) 12 hour))))) + (#\m . ,(time-lambda (mon) (format nil "~2,'0D" mon))) + (#\M . ,(time-lambda (min) (format nil "~2,'0D" min))) + (#\n . ,(time-lambda () "~%%")) ;; two % to avoid parsing errors + ;; %N nanoseconds (000000000..999999999) + (#\p . ,(time-lambda (hour) (if (>= hour 12) "PM" "AM"))) + (#\P . ,(time-lambda (hour) (if (>= hour 12) "pm" "am"))) + (#\r . ,(time-lambda (hour min sec) + (let (hour-local am-pm) + (cond + ((> hour 12) + (setf hour-local (- hour 12) am-pm "PM")) + ((= hour 12) + (setf hour-local hour am-pm "PM")) + (t + (setf hour-local + (if (zerop hour) 12 hour) am-pm "AM"))) + (format nil "~2,'0D:~2,'0D:~2,'0D ~A" + hour-local min sec am-pm)))) + (#\R . ,(time-lambda (hour min) (format nil "~2,'0D:~2,'0D" hour min))) + (#\s . ,(time-lambda (sec min hour dom mon year) + (format nil "~D" + (- (encode-universal-time + sec min hour dom mon year) + (encode-universal-time 0 0 0 1 1 1970 0))))) + (#\S . ,(time-lambda (sec) (format nil "~2,'0D" sec))) + (#\t . ,(time-lambda () "~T")) + (#\T . ,(time-lambda (hour min sec) + (format nil "~2,'0D:~2,'0D:~2,'0D" hour min sec))) + (#\u . ,(time-lambda (dow) (format nil "~D" (+ dow 1)))) + ;; %U week number of year, with Sunday as first day of week (00..53) + ;; %V ISO week number, with Monday as first day of week (01..53) + (#\w . ,(time-lambda (dow) (format nil "~D" (- dow 1)))) + ;; %W week number of year, with Monday as first day of week (00..53) + ;; %x locale's date representation (e.g., 12/31/99) + ;; %X locale's time representation (e.g., 23:13:48) + (#\y . ,(time-lambda (year) (subseq (format nil "~D" year) 2 4))) + (#\Y . ,(time-lambda (year) (format nil "~D" year))) + (#\z . ,(time-lambda (tz dstp) + (multiple-value-bind (hour-local decimal-local) + (truncate (+ (* (float tz) -1) (if dstp 1 0))) + (format nil "~A~2,'0D~2,'0D" + (if (> hour-local 0) '+ '-) + (abs hour-local) + (truncate (if (/= decimal-local 0) + (* 60 decimal-local) 0)))))) + ;; %:z +hh:mm numeric timezone (e.g., -04:00) + ;; %::z +hh:mm:ss numeric time zone (e.g., -04:00:00) + ;; %:::z numeric time zone with : to necessary precision (e.g., -04, +05:30) + ;; %Z alphabetic time zone abbreviation (e.g., EDT) + ) + "An alist for the substitution in `format-time-string'.") + +(defvar *format-time-string-default* "%a %b %e %k:%M:%S %Y" + "The default value for `format-time-string', (e.g, Thu Mar 3 23:05:25 2005).") + +(defun format-time-string (&optional format-string time) + "Return a formatted date-time string of TIME or `get-decoded-time'. + +FORMAT-STRING defaults to `*format-time-string-default*' and accepts +the 'date' command options except the following ones: %g, %G, %j, %N, +%U, %V, %W, %x, %X, %:z, %::z, %:::z and %Z." + (let* ((time-string (or format-string + *format-time-string-default*))) + (when (> 2 (length time-string)) + (error "FORMAT-STRING should contains at least two characters.")) + (multiple-value-bind (sec min hour dom mon year dow dstp tz) + (or time (get-decoded-time)) + (loop + for format-position = (position #\% time-string :start + (or format-position 0)) + while format-position do + (let* ((format-character (aref time-string (+ format-position 1))) + (action (or (cdr (assoc format-character + *format-time-string-alist*)) + (error "Invalid format option %~C" + format-character)))) + (setf time-string + (concatenate 'string + (subseq time-string 0 format-position) + (funcall action sec min hour dom + mon year dow dstp tz) + (subseq time-string (+ format-position 2)))) + (when (char-equal #\% format-character) ; escape character + (incf format-position))))) + (format nil time-string))) + +;;; time.lisp end here diff --git a/types.lisp b/types.lisp new file mode 100644 index 0000000..a9ae4c3 --- /dev/null +++ b/types.lisp @@ -0,0 +1,165 @@ +;; Copyright (C) 2003, 2008 * +;; +;; This file is part of stumpwm. +;; +;; stumpwm is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; stumpwm is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA +;; +;; Commentary: +;; +;; Types code from user.lisp. +;; +;; * user.lisp Copyright (C) 2003 Shawn Betts +;; +;; Code: + +(in-package :stumpwm) + +(export '(define-stumpwm-type)) + +(defmacro define-stumpwm-type (type (input prompt) &body body) + `(setf (gethash ,type *command-type-hash*) + (lambda (,input ,prompt) + ,@body))) + +(define-stumpwm-type :y-or-n (input prompt) + (let ((s (or (argument-pop input) + (read-one-line (current-screen) (concat prompt "(y/n): "))))) + (when s + (values (list (equal s "y")))))) + +(define-stumpwm-type :variable (input prompt) + (lookup-symbol (argument-pop-or-read input prompt))) + +(define-stumpwm-type :function (input prompt) + (multiple-value-bind (sym pkg var) + (lookup-symbol (argument-pop-or-read input prompt)) + (if (symbol-function sym) + (symbol-function sym) + (throw 'error (format nil "the symbol ~a::~a has no function." + (package-name pkg) var))))) + +(define-stumpwm-type :command (input prompt) + (or (argument-pop input) + (string-trim " " + (completing-read (current-screen) + prompt + (all-commands))))) + +(define-stumpwm-type :key-seq (input prompt) + (labels ((update (seq) + (message "~a: ~{~a ~}" + prompt + (mapcar 'print-key (reverse seq))))) + (let ((rest (argument-pop-rest input))) + (or (and rest (parse-key-seq rest)) + ;; read a key sequence from the user + (with-focus (screen-key-window (current-screen)) + (message "~a" prompt) + (nreverse (second (multiple-value-list + (read-from-keymap *top-map* #'update))))))))) + +(define-stumpwm-type :window-number (input prompt) + (let ((n (or (argument-pop input) + (completing-read + (current-screen) + prompt + (mapcar 'prin1-to-string + (mapcar 'window-number + (group-windows (current-group)))))))) + (when n + (handler-case + (parse-integer n) + (parse-error (c) + (declare (ignore c)) + (throw 'error "Number required.")))))) + +(define-stumpwm-type :number (input prompt) + (let ((n (or (argument-pop input) + (read-one-line (current-screen) prompt)))) + (when n + (handler-case + (parse-integer n) + (parse-error (c) + (declare (ignore c)) + (throw 'error "Number required.")))))) + +(define-stumpwm-type :string (input prompt) + (or (argument-pop input) + (read-one-line (current-screen) prompt))) + +(define-stumpwm-type :key (input prompt) + (let ((s (or (argument-pop input) + (read-one-line (current-screen) prompt)))) + (when s + (kbd s)))) + +(define-stumpwm-type :window-name (input prompt) + (or (argument-pop input) + (completing-read (current-screen) prompt + (mapcar 'window-name + (group-windows (current-group)))))) + +(define-stumpwm-type :gravity (input prompt) +"Set the current window's gravity." + (let* ((values '(("center" :center) + ("top" :top) + ("right" :right) + ("bottom" :bottom) + ("left" :left) + ("top-right" :top-right) + ("top-left" :top-left) + ("bottom-right" :bottom-right) + ("bottom-left" :bottom-left))) + (gravity + (second (assoc + (string-trim " " + (argument-pop-or-read input prompt values)) + values :test 'string-equal)))) + (or gravity + (throw 'error "No matching gravity.")))) + +(define-stumpwm-type :group (input prompt) + (let ((match (select-group + (current-screen) + (or (argument-pop input) + (completing-read (current-screen) prompt + (mapcar 'group-name + (screen-groups + (current-screen)))))))) + (or match + (throw 'error "No Such Group.")))) + +(define-stumpwm-type :frame (input prompt) + (declare (ignore prompt)) + (let ((arg (argument-pop input))) + (if arg + (or (find arg (group-frames (current-group)) + :key (lambda (f) + (string (get-frame-number-translation f))) + :test 'string=) + (throw 'error "Frame not found.")) + (or (choose-frame-by-number (current-group)) + (throw 'error :abort))))) + +(define-stumpwm-type :shell (input prompt) + (or (argument-pop-rest input) + (completing-read (current-screen) prompt 'programs-in-path))) + +(define-stumpwm-type :rest (input prompt) + (or (argument-pop-rest input) + (read-one-line (current-screen) prompt))) + +;;; types.lisp ends here diff --git a/user.lisp b/user.lisp index 6a0b347..ad82c7b 100644 --- a/user.lisp +++ b/user.lisp @@ -26,309 +26,11 @@ (in-package :stumpwm) -(export '(*root-map* - argument-line-end-p - argument-pop - argument-pop-or-read - argument-pop-rest - define-stumpwm-command - defcommand - defcommand-alias - define-stumpwm-type - pathname-is-executable-p - programs-in-path - restarts-menu - run-commands - run-or-raise - run-shell-command - set-prefix-key)) - -(defvar *root-map* nil - "This is the keymap by default bound to @kbd{C-t}. It is known as the @dfn{prefix map}.") - -;; Do it this way so its easier to wipe the map and get a clean one. -(when (null *root-map*) - (setf *root-map* - (let ((m (make-sparse-keymap))) - (define-key m (kbd "c") "exec xterm") - (define-key m (kbd "C-c") "exec xterm") - (define-key m (kbd "e") "emacs") - (define-key m (kbd "C-e") "emacs") - (define-key m (kbd "n") "pull-hidden-next") - (define-key m (kbd "C-n") "pull-hidden-next") - (define-key m (kbd "M-n") "next") - (define-key m (kbd "C-M-n") "next-in-frame") - (define-key m (kbd "SPC") "pull-hidden-next") - (define-key m (kbd "C-SPC") "pull-hidden-next") - (define-key m (kbd "p") "pull-hidden-previous") - (define-key m (kbd "C-p") "pull-hidden-previous") - (define-key m (kbd "M-p") "prev") - (define-key m (kbd "C-M-p") "prev-in-frame") - (define-key m (kbd "w") "windows") - (define-key m (kbd "C-w") "windows") - (define-key m (kbd "W") "place-existing-windows") - (define-key m (kbd "k") "delete") - (define-key m (kbd "C-k") "delete") - (define-key m (kbd "K") "kill") - (define-key m (kbd "b") "banish") - (define-key m (kbd "C-b") "banish") - (define-key m (kbd "a") "time") - (define-key m (kbd "C-a") "time") - (define-key m (kbd "'") "select") - (define-key m (kbd "\"") "windowlist") - (define-key m (kbd "C-t") "pull-hidden-other") - (define-key m (kbd "M-t") "other-in-frame") - (define-key m (kbd "!") "exec") - (define-key m (kbd "C-g") "abort") - (define-key m (kbd "0") "pull 0") - (define-key m (kbd "1") "pull 1") - (define-key m (kbd "2") "pull 2") - (define-key m (kbd "3") "pull 3") - (define-key m (kbd "4") "pull 4") - (define-key m (kbd "5") "pull 5") - (define-key m (kbd "6") "pull 6") - (define-key m (kbd "7") "pull 7") - (define-key m (kbd "8") "pull 8") - (define-key m (kbd "9") "pull 9") - (define-key m (kbd "R") "remove") - (define-key m (kbd "s") "vsplit") - (define-key m (kbd "S") "hsplit") - (define-key m (kbd "r") "iresize") - (define-key m (kbd "o") "fnext") - (define-key m (kbd "TAB") "fnext") - (define-key m (kbd "f") "fselect") - (define-key m (kbd "F") "curframe") - (define-key m (kbd "t") "meta C-t") - (define-key m (kbd "C-N") "number") - (define-key m (kbd ";") "colon") - (define-key m (kbd ":") "eval") - (define-key m (kbd "C-h") "help") - (define-key m (kbd "-") "fclear") - (define-key m (kbd "Q") "only") - (define-key m (kbd "Up") "move-focus up") - (define-key m (kbd "Down") "move-focus down") - (define-key m (kbd "Left") "move-focus left") - (define-key m (kbd "Right") "move-focus right") - (define-key m (kbd "M-Up") "move-window up") - (define-key m (kbd "M-Down") "move-window down") - (define-key m (kbd "M-Left") "move-window left") - (define-key m (kbd "M-Right") "move-window right") - (define-key m (kbd "v") "version") - (define-key m (kbd "#") "mark") - (define-key m (kbd "m") "lastmsg") - (define-key m (kbd "C-m") "lastmsg") - (define-key m (kbd "G") "vgroups") - (define-key m (kbd "g") '*groups-map*) - (define-key m (kbd "F1") "gselect 1") - (define-key m (kbd "F2") "gselect 2") - (define-key m (kbd "F3") "gselect 3") - (define-key m (kbd "F4") "gselect 4") - (define-key m (kbd "F5") "gselect 5") - (define-key m (kbd "F6") "gselect 6") - (define-key m (kbd "F7") "gselect 7") - (define-key m (kbd "F8") "gselect 8") - (define-key m (kbd "F9") "gselect 9") - (define-key m (kbd "F10") "gselect 10") - (define-key m (kbd "F11") "fullscreen") - (define-key m (kbd "?") "help") - (define-key m (kbd "+") "balance-frames") - (define-key m (kbd "A") "title") - (define-key m (kbd "h") '*help-map*) - m))) - -(defvar *help-map* nil - "Help related bindings hang from this keymap") - -(when (null *help-map*) - (setf *help-map* - (let ((m (make-sparse-keymap))) - (define-key m (kbd "v") "describe-variable") - (define-key m (kbd "f") "describe-function") - (define-key m (kbd "k") "describe-key") - (define-key m (kbd "w") "where-is") - m))) - -(defstruct command-alias - from to) - -(defstruct command - name args) - -(defvar *command-hash* (make-hash-table :test 'eq) - "A list of interactive stumpwm commands.") - -(defmacro defcommand (name (&rest args) (&rest interactive-args) &body body) - "Create a command function and store its interactive hints in *command-hash*." - (check-type name symbol) - `(progn - (defun ,name ,args ,@body) - (setf (gethash ',name *command-hash*) - (make-command :name ',name - :args ',interactive-args)))) - -(defmacro define-stumpwm-command (name (&rest args) &body body) - "Deprecated. use `defcommand' instead." - (check-type name string) - (setf name (intern (string-upcase name))) - `(progn - (defun ,name ,(mapcar 'car args) ,@body) - (setf (gethash ',name *command-hash*) - (make-command :name ',name - :args ',(mapcar 'rest args))))) - -(defmacro defcommand-alias (alias original) - "Since interactive commands are functions and can conflict with -package symbols. But for backwards compatibility this macro creates an -alias name for the command that is only accessible interactively." - `(setf (gethash ',alias *command-hash*) - (make-command-alias :from ',alias - :to ',original))) - -(defun all-commands () - "Return a list of all interactive commands as strings." - (let (acc) - (maphash (lambda (k v) - (declare (ignore v)) - (push (string-downcase k) acc)) - *command-hash*) - (sort acc 'string<))) - -(defun restarts-menu (err) - "Display a menu with the active restarts and let the user pick -one. Error is the error being recovered from. If the user aborts the -menu, the error is re-signalled." - (let ((restart (select-from-menu (current-screen) - (mapcar (lambda (r) - (list (format nil "[~a] ~a" - (restart-name r) - (substitute #\Space - #\Newline - (write-to-string r :escape nil))) - r)) - ;; a crusty way to get only - ;; the restarts from - ;; stumpwm's top-level - ;; restart inward. - (reverse (member 'top-level - (reverse (compute-restarts)) - :key 'restart-name))) - (format nil "Error: ~a" - (substitute #\Space - #\Newline - (write-to-string err :escape nil)))))) - (when restart - (invoke-restart (second restart))))) - -(defun focus-next-window (group) - (focus-forward group (sort-windows group))) - -(defun focus-prev-window (group) - (focus-forward group - (reverse - (sort-windows group)))) +(export '(run-shell-command)) -(defcommand next () () - "Go to the next window in the window list." - (let ((group (current-group))) - (if (group-current-window group) - (focus-next-window group) - (other-window group)))) - -(defcommand prev () () - "Go to the previous window in the window list." - (let ((group (current-group))) - (if (group-current-window group) - (focus-prev-window group) - (other-window group)))) - -(defun pull-window (win &optional (to-frame (tile-group-current-frame (window-group win)))) - (let ((f (window-frame win)) - (group (window-group win))) - (unless (eq (frame-window to-frame) win) - (xwin-hide win) - (setf (window-frame win) to-frame) - (maximize-window win) - (when (eq (window-group win) (current-group)) - (xwin-unhide (window-xwin win) (window-parent win))) - ;; We have to restore the focus after hiding. - (when (eq win (screen-focus (window-screen win))) - (screen-set-focus (window-screen win) win)) - (frame-raise-window group to-frame win) - ;; if win was focused in its old frame then give the old - ;; frame the frame's last focused window. - (when (eq (frame-window f) win) - ;; the current value is no longer valid. - (setf (frame-window f) nil) - (frame-raise-window group f (first (frame-windows group f)) nil))))) - -;; In the future, this window will raise the window into the current -;; frame. -(defun focus-forward (group window-list &optional pull-p (predicate (constantly t))) - "Set the focus to the next item in window-list from the focused -window. If PULL-P is T then pull the window into the current -frame." - ;; The window with focus is the "current" window, so find it in the - ;; list and give that window focus - (let* ((w (group-current-window group)) - (wins (remove-if-not predicate (cdr (member w window-list)))) - (nw (if (null wins) - ;; If the last window in the list is focused, then - ;; focus the first one. - (car (remove-if-not predicate window-list)) - ;; Otherwise, focus the next one in the list. - (first wins)))) - ;; there's still the case when the window is the only one in the - ;; list, so make sure its not the same as the current window. - (if (and nw - (not (eq w nw))) - (if pull-p - (pull-window nw) - (frame-raise-window group (window-frame nw) nw)) - (message "No other window.")))) - -(defcommand delete-current-window () () - "Delete the current window. This is a request sent to the window. The -window's client may decide not to grant the request or may not be able -to if it is unresponsive." - (let ((group (current-group))) - (when (group-current-window group) - (delete-window (group-current-window group))))) - -(defcommand-alias delete delete-current-window) - -(defcommand kill-current-window () () -"`Tell X to disconnect the client that owns the current window. if address@hidden didn't work, try this." - (let ((group (current-group))) - (when (group-current-window group) - (xwin-kill (window-xwin (group-current-window group)))))) - -(defcommand-alias kill kill-current-window) - -(defun banish-pointer (&optional (where *banish-pointer-to*)) - "Move the pointer to the lower right corner of the head, or - WHEREever (one of :screen :head :frame or :window)" - (let* ((screen (current-screen)) - (group (current-group)) - (head (current-head)) - (frame (tile-group-current-frame group)) - (window (frame-window frame)) - (x (1- (+ (frame-x frame) (frame-width frame)))) - (y (1- (+ (frame-display-y group frame) (frame-display-height group frame))))) - (ecase where - (:screen - (setf x (1- (+ (screen-x screen) (screen-width screen))) - y (1- (+ (screen-y screen) (screen-height screen))))) - (:head - (setf x (1- (+ (head-x head) (head-width head))) - y (1- (+ (head-y head) (head-height head))))) - (:frame) - (:window - (when window - (let ((win (window-parent window))) - (setf x (1- (+ (xlib:drawable-x win) (xlib:drawable-width win))) - y (1- (+ (xlib:drawable-y win) (xlib:drawable-height win)))))))) - (warp-pointer (group-screen group) x y))) +;;; ------------------------------------------------------------------ +;;; Rat +;;; ------------------------------------------------------------------ (defcommand banish (&optional where) (:rest) "Warp the mouse the lower right corner of the current head." @@ -349,154 +51,31 @@ to if it is unresponsive." (when (current-window) (send-fake-click (current-window) button))) -(defun echo-windows (group fmt &optional (windows (group-windows group))) - "Print a list of the windows to the screen." - (let* ((wins (sort1 windows '< :key 'window-number)) - (highlight (position (group-current-window group) wins)) - (names (mapcar (lambda (w) - (format-expand *window-formatters* fmt w)) wins))) - (if (null wins) - (echo-string (group-screen group) "No Managed Windows") - (echo-string-list (group-screen group) names highlight)))) +;;; ------------------------------------------------------------------ +;;; Keyboard +;;; ------------------------------------------------------------------ -(defcommand windows (&optional (fmt *window-format*)) (:rest) - "Display a list of managed windows. The optional argument @var{fmt} can -be used to override the default window formatting." - (echo-windows (current-group) fmt)) +(defcommand meta (key) ((:key "Key: ")) +"Send a fake key to the current window. @var{key} is a typical StumpWM key, like @kbd{C-M-o}." + (send-meta-key (current-screen) key)) -(defcommand echo-frame-windows (&optional (fmt *window-format*)) (:rest) - (echo-windows (current-group) fmt (frame-windows (current-group) - (tile-group-current-frame (current-group))))) +(defcommand escape (key) ((:string "Key: ")) + "Set the prefix key. Here's how you would change the prefix key to @kbd{C-z}. -(defcommand-alias frame-windows echo-frame-windows) address@hidden +escape C-z address@hidden example" + (set-prefix-key (kbd key))) -(defcommand title (title) ((:rest "Set window's title to: ")) - (if (current-window) - (setf (window-user-title (current-window)) title) - (message "No Focused Window"))) +(defcommand bind (key command) + ((:text "Key Chord: ") + (:rest "Command: ")) + "Hang a key binding off the escape key." + (define-key *root-map* (kbd key) command)) -;;; (format-time-stringc ...) section -(defmacro time-lambda (used-var &body body) - `(lambda (sec min hour dom mon year dow dstp tz) - (declare (ignore ,@(set-difference '(sec min hour dom mon year dow dstp tz) used-var))) - ,@body)) - -(defvar *month-names* - #("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December")) - -(defvar *day-names* - #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) - -;; `date --help` with date_5.97 -;; `date --help` with date_5.97 -(defvar *format-time-string-alist* - `((#\% . ,(time-lambda () "%")) - (#\a . ,(time-lambda (dow) (subseq (aref *day-names* dow) 0 3))) - (#\A . ,(time-lambda (dow) (aref *day-names* dow))) - (#\b . ,(time-lambda (mon) (subseq (aref *month-names* (- mon 1)) 0 3))) - (#\B . ,(time-lambda (mon) (aref *month-names* (- mon 1)))) - (#\c . ,(time-lambda (dow mon dom hour min sec year) - (format nil "~A ~A ~2,'0D ~2,'0D:~2,'0D:~2,'0D ~D" - (subseq (aref *day-names* dow) 0 3) - (subseq (aref *month-names* (- mon 1)) 0 3) - dom hour min sec year))) - (#\C . ,(time-lambda (year) (subseq (format nil "~D" year) 0 2))) - (#\d . ,(time-lambda (dom) (format nil "~2,'0D" dom))) - (#\D . ,(time-lambda (mon dom year) - (format nil "~2,'0D/~2,'0D/~A" - mon dom (subseq (format nil "~D" year) 2 4)))) - (#\e . ,(time-lambda (dom) (format nil "~2,' D" dom))) - (#\F . ,(time-lambda (year mon dom) (format nil "~D-~2,'0D-~2,'0D" year mon dom))) - ;; %g last two digits of year of ISO week number (see %G) - ;; %G year of ISO week number (see %V); normally useful only with %V - (#\h . ,(time-lambda (mon) (subseq (aref *month-names* (- mon 1)) 0 3))) - (#\H . ,(time-lambda (hour) (format nil "~2,'0D" hour))) - (#\I . ,(time-lambda (hour) - (format nil "~2,'0D" (if (> hour 12) (- hour 12) (if (zerop hour) 12 hour))))) - ;; %j day of year (001..366) - (#\k . ,(time-lambda (hour) (format nil "~2,D" hour))) - (#\l . ,(time-lambda (hour) - (format nil "~2,D" (if (> hour 12) (- hour 12) (if (zerop hour) 12 hour))))) - (#\m . ,(time-lambda (mon) (format nil "~2,'0D" mon))) - (#\M . ,(time-lambda (min) (format nil "~2,'0D" min))) - (#\n . ,(time-lambda () "~%%")) ;; two % to avoid parsing errors - ;; %N nanoseconds (000000000..999999999) - (#\p . ,(time-lambda (hour) (if (>= hour 12) "PM" "AM"))) - (#\P . ,(time-lambda (hour) (if (>= hour 12) "pm" "am"))) - (#\r . ,(time-lambda (hour min sec) - (let (hour-local am-pm) - (cond - ((> hour 12) - (setf hour-local (- hour 12) am-pm "PM")) - ((= hour 12) - (setf hour-local hour am-pm "PM")) - (t - (setf hour-local (if (zerop hour) 12 hour) am-pm "AM"))) - (format nil "~2,'0D:~2,'0D:~2,'0D ~A" - hour-local min sec am-pm)))) - (#\R . ,(time-lambda (hour min) (format nil "~2,'0D:~2,'0D" hour min))) - (#\s . ,(time-lambda ( sec min hour dom mon year) - (format nil "~D" - (- (encode-universal-time - sec min hour dom mon year) - (encode-universal-time 0 0 0 1 1 1970 0))))) - (#\S . ,(time-lambda (sec) (format nil "~2,'0D" sec))) - (#\t . ,(time-lambda () "~T")) - (#\T . ,(time-lambda (hour min sec) - (format nil "~2,'0D:~2,'0D:~2,'0D" hour min sec))) - (#\u . ,(time-lambda (dow) (format nil "~D" (+ dow 1)))) - ;; %U week number of year, with Sunday as first day of week (00..53) - ;; %V ISO week number, with Monday as first day of week (01..53) - (#\w . ,(time-lambda (dow) (format nil "~D" (- dow 1)))) - ;; %W week number of year, with Monday as first day of week (00..53) - ;; %x locale's date representation (e.g., 12/31/99) - ;; %X locale's time representation (e.g., 23:13:48) - (#\y . ,(time-lambda (year) (subseq (format nil "~D" year) 2 4))) - (#\Y . ,(time-lambda (year) (format nil "~D" year))) - (#\z . ,(time-lambda (tz dstp) - (multiple-value-bind (hour-local decimal-local) - (truncate (+ (* (float tz) -1) (if dstp 1 0))) - (format nil "~A~2,'0D~2,'0D" - (if (> hour-local 0) '+ '-) (abs hour-local) - (truncate (if (/= decimal-local 0) - (* 60 decimal-local) 0)))))) - ;; %:z +hh:mm numeric timezone (e.g., -04:00) - ;; %::z +hh:mm:ss numeric time zone (e.g., -04:00:00) - ;; %:::z numeric time zone with : to necessary precision (e.g., -04, +05:30) - ;; %Z alphabetic time zone abbreviation (e.g., EDT) - ) - "An alist for the substitution in `format-time-string'.") - -(defvar *format-time-string-default* "%a %b %e %k:%M:%S %Y" - "The default value for `format-time-string', (e.g, Thu Mar 3 23:05:25 2005).") - -(defun format-time-string (&optional format-string time) - "Return a formatted date-time string of TIME or `get-decoded-time'. - -FORMAT-STRING defaults to `*format-time-string-default*' and accepts -the 'date' command options except the following ones: %g, %G, %j, %N, -%U, %V, %W, %x, %X, %:z, %::z, %:::z and %Z." - (let* ((time-string (or format-string - *format-time-string-default*))) - (when (> 2 (length time-string)) - (error "FORMAT-STRING should contains at least two characters.")) - (multiple-value-bind (sec min hour dom mon year dow dstp tz) - (or time (get-decoded-time)) - (loop - for format-position = (position #\% time-string :start (or format-position 0)) - while format-position do - (let* ((format-character (aref time-string (+ format-position 1))) - (action (or (cdr (assoc format-character - *format-time-string-alist*)) - (error "Invalid format option %~C" - format-character)))) - (setf time-string (concatenate 'string - (subseq time-string 0 format-position) - (funcall action sec min hour dom mon year dow dstp tz) - (subseq time-string (+ format-position 2)))) - (when (char-equal #\% format-character) ; escape character - (incf format-position))))) - (format nil time-string))) +;;; ------------------------------------------------------------------ +;;; Time & Date +;;; ------------------------------------------------------------------ (defcommand echo-date () () "Display the date and time." @@ -504,65 +83,9 @@ the 'date' command options except the following ones: %g, %G, %j, %N, (defcommand-alias time echo-date) -(defun select-window (group query) - "Read input from the user and go to the selected window." - (let (match) - (labels ((match (win) - (let* ((wname (window-name win)) - (end (min (length wname) (length query)))) - (string-equal wname query :end1 end :end2 end)))) - (unless (null query) - (setf match (find-if #'match (group-windows group)))) - (when match - (frame-raise-window group (window-frame match) match))))) - -(defcommand select (win) ((:window-name "Select: ")) - "Switch to the first window that starts with @var{win}." - (select-window (current-group) win)) - -(defun select-window-number (group num) - (labels ((match (win) - (= (window-number win) num))) - (let ((win (find-if #'match (group-windows group)))) - (when win - (frame-raise-window group (window-frame win) win))))) - -(defun other-window (group) - (let* ((wins (group-windows group)) - ;; the frame could be empty - (win (if (group-current-window group) - (second wins) - (first wins)))) - (if win - (frame-raise-window group (window-frame win) win) - (echo-string (group-screen group) "No other window.")))) - -(defcommand other () () - "Switch to the window last focused." - (other-window (current-group))) - -(defun programs-in-path (base &optional full-path (path (split-string (getenv "PATH") ":"))) - "Return a list of programs in the path that start with @var{base}. if address@hidden is @var{t} then return the full path, otherwise just -return the filename. @var{path} is by default the @env{PATH} -evironment variable but can be specified. It should be a string containing -each directory seperated by a colon." - (loop - for p in path - for dir = (probe-path p) - when dir - nconc (loop - for file in (directory (merge-pathnames (make-pathname :name :wild) dir)) - for namestring = (file-namestring file) - when (and (string= base namestring - :end1 (min (length base) - (length namestring)) - :end2 (min (length base) - (length namestring))) - (pathname-is-executable-p file)) - collect (if full-path - (namestring file) - namestring)))) +;;; ------------------------------------------------------------------ +;;; Running commands +;;; ------------------------------------------------------------------ (defcommand run-shell-command (cmd &optional collect-output-p) ((:shell "/bin/sh -c ")) "Run the specified shell command. If @var{collect-output-p} is @code{T} @@ -575,14 +98,188 @@ such a case, kill the shell command to resume StumpWM." (defcommand-alias exec run-shell-command) -(defun split-frame-in-dir (group dir) - (let ((f (tile-group-current-frame group))) - (if (split-frame group dir) - (progn - (when (frame-window f) - (update-window-border (frame-window f))) - (show-frame-indicator group)) - (message "Cannot split smaller than minimum size.")))) +(defcommand eval-line (cmd) ((:rest "Eval: ")) + (handler-case + (message "^20~{~a~^~%~}" + (mapcar 'prin1-to-string + (multiple-value-list (eval (read-from-string cmd))))) + (error (c) + (err "^B^1*~A" c)))) + +(defcommand-alias eval eval-line) + +(defcommand colon (&optional initial-input) (:rest) + "Read a command from the user. @var{initial-text} is optional. When +supplied, the text will appear in the prompt." + (let ((cmd (completing-read (current-screen) ": " (all-commands) (or initial-input "")))) + (unless cmd + (throw 'error :abort)) + (when (plusp (length cmd)) + (interactive-command cmd)))) + +(defcommand keyboard-quit () () + "" + ;; This way you can exit from command mode + (when (pop-top-map) + (message "Exited."))) + +(defcommand-alias abort keyboard-quit) + +(defcommand command-mode () () +"Command mode allows you to type ratpoison commands without needing the address@hidden prefix. Keys not bound in StumpWM will still get sent to the +current window. To exit command mode, type @key{C-g}." + (message "Press C-g to exit command-mode.") + (push-top-map *root-map*)) + +(defcommand emacs () () + "Start emacs unless it is already running, in which case focus it." + (run-or-raise "emacs" '(:class "Emacs"))) + +;;; ------------------------------------------------------------------ +;;; Echoing things +;;; ------------------------------------------------------------------ + +(defcommand echo (string) ((:rest "Echo: ")) + "Display @var{string} in the message bar." + ;; The purpose of echo is always to pop up a message window. + (let ((*executing-stumpwm-command* nil)) + (message "~a" string))) + +(defvar *lastmsg-nth* nil) + +(defcommand lastmsg () () + ;; Allow the user to go back through the message history + (if (string= *last-command* "lastmsg") + (progn + (incf *lastmsg-nth*) + (if (>= *lastmsg-nth* (length (screen-last-msg (current-screen)))) + (setf *lastmsg-nth* 0))) + (setf *lastmsg-nth* 0)) + (if (screen-last-msg (current-screen)) + (echo-nth-last-message (current-screen) *lastmsg-nth*) + (message "No last message."))) + +;;; ------------------------------------------------------------------ +;;; Window manager commands +;;; ------------------------------------------------------------------ + +(defcommand loadrc () () +"Reload the @file{~/.stumpwmrc} file." + (handler-case + (progn + (with-restarts-menu (load-rc-file nil))) + (error (c) + (message "^1*^BError loading rc file: ^n~A" c)) + (:no-error (&rest args) + (declare (ignore args)) + (message "rc file loaded successfully.")))) + +(defcommand quit () () +"Quit StumpWM." + (throw :top-level :quit)) + +(defcommand soft-restart () () + "Soft Restart StumpWM. The lisp process isn't restarted. Instead, +control jumps to the very beginning of the stumpwm program. This +differs from a theoretical hard restart, which would restart the unix +process." + (throw :top-level :restart)) + +(defcommand reload () () +"Reload StumpWM using @code{asdf}." + (message "Reloading StumpWM...") + #+asdf (with-restarts-menu + (asdf:operate 'asdf:load-op :stumpwm)) + #-asdf (message "^B^1*Sorry, StumpWM can only be reloaded with asdf (for now.)") + #+asdf (message "Reloading StumpWM...^B^2*Done^n.")) + +(defcommand copy-unhandled-error () () + "When an unhandled error occurs, StumpWM restarts and attempts to +continue. Unhandled errors should be reported to the mailing list so +they can be fixed. Use this command to copy the unhandled error and +backtrace to the X11 selection so you can paste in your email when +submitting the bug report." + (if *last-unhandled-error* + (progn + (set-x-selection (format nil "~a~%~a" (first *last-unhandled-error*) (second *last-unhandled-error*))) + (message "Copied to clipboard.")) + (message "There was no unhandled error!"))) + +(defcommand mode-line () () + "A command to toggle the mode line visibility." + (toggle-mode-line (current-screen) (current-head))) + +;;; ------------------------------------------------------------------ +;;; Help +;;; ------------------------------------------------------------------ + +(defcommand help () () +"Display all the bindings in @var{*root-map*}." + (display-keybinding '*root-map*)) + +(defcommand commands () () + (let* ((screen (current-screen)) + (data (all-commands)) + (cols (ceiling (length data) + (truncate (head-height (current-head)) + (font-height (screen-font screen)))))) + (message-no-timeout "~{~a~^~%~}" + (columnize data cols)))) + +(defcommand describe-key (keys) ((:key-seq "Describe Key: ")) +"Either interactively type the key sequence or supply it as text. This +command prints the command bound to the specified key sequence." + (let ((cmd (lookup-key-sequence *top-map* keys))) + (if cmd + (message "~{~a~^ ~} is bound to \"~a\"." (mapcar 'print-key keys) cmd) + (message "~{~a~^ ~} is not bound." (mapcar 'print-key keys))))) + +(defcommand describe-variable (var) ((:variable "Describe Variable: ")) +"Print the online help associated with the specified variable." + (message-no-timeout "~a" + (with-output-to-string (s) + (describe var s)))) + +(defcommand describe-function (fn) ((:function "Describe Function: ")) +"Print the online help associated with the specified function." + (message-no-timeout "~a" + (with-output-to-string (s) + (describe fn s)))) + +(defcommand describe-command (com) ((:command "Describe Command: ")) + "Print the online help associated with the specified command." + (message-no-timeout "Command \"~a\":~%~a" com + (documentation (get-command-structure com) 'function))) + +(defcommand where-is (cmd) ((:rest "Where is command: ")) +"Print the key sequences bound to the specified command." + (message-no-timeout "\"~a\" is on ~{~a~^, ~}" + cmd + (mapcar 'print-key-seq (search-kmap cmd *top-map*)))) + +;;; ------------------------------------------------------------------ +;;; Screens +;;; ------------------------------------------------------------------ + +(defcommand snext () () +"Go to the next screen." + (switch-to-screen (next-screen)) + (show-frame-indicator (current-group))) + +(defcommand sprev () () +"Go to the previous screen." + (switch-to-screen (next-screen (reverse (sort-screens)))) + (show-frame-indicator (current-group))) + +(defcommand sother () () +"Go to the last screen." + (switch-to-screen (cadr *screen-list*)) + (show-frame-indicator (current-group))) + +;;; ------------------------------------------------------------------ +;;; Frames +;;; ------------------------------------------------------------------ (defcommand hsplit () () "Split the current frame into 2 side-by-side frames." @@ -658,48 +355,14 @@ space." (show-frame-indicator group)) (sync-frame-windows group (tile-group-current-frame group)))))) -(defcommand fullscreen () () - "Toggle the fullscreen mode of the current widnow. Use this for clients -with broken (non-NETWM) fullscreen implemenations, such as any program -using SDL." - (update-fullscreen (current-window) 2)) +(defcommand fclear () () +"Clear the current frame." + (clear-frame (tile-group-current-frame (current-group)) (current-group))) (defcommand curframe () () "Display a window indicating which frame is focused." (show-frame-indicator (current-group) t)) -(defun focus-frame-next-sibling (group) - (let* ((sib (next-sibling (tile-group-frame-tree group) - (tile-group-current-frame group)))) - (when sib - (focus-frame group (tree-accum-fn sib - (lambda (x y) - (declare (ignore y)) - x) - 'identity)) - (show-frame-indicator group)))) - -(defun focus-last-frame (group) - ;; make sure the last frame still exists in the frame tree - (when (and (tile-group-last-frame group) - (find (tile-group-last-frame group) (group-frames group))) - (focus-frame group (tile-group-last-frame group)))) - -(defun focus-frame-after (group frames) - "Given a list of frames focus the next one in the list after -the current frame." - (let ((rest (cdr (member (tile-group-current-frame group) frames :test 'eq)))) - (focus-frame group - (if (null rest) - (car frames) - (car rest))))) - -(defun focus-next-frame (group) - (focus-frame-after group (group-frames group))) - -(defun focus-prev-frame (group) - (focus-frame-after group (nreverse (group-frames group)))) - (defcommand fnext () () "Cycle through the frame tree to the next frame." (focus-next-frame (current-group))) @@ -713,22 +376,6 @@ these two frames are siblings." "Jump to the last frame that had focus." (focus-last-frame (current-group))) -(defun choose-frame-by-number (group) - "show a number in the corner of each frame and wait for the user to -select one. Returns the selected frame or nil if aborted." - (let* ((wins (progn - (draw-frame-outlines group) - (draw-frame-numbers group))) - (ch (read-one-char (group-screen group))) - (num (read-from-string (string ch) nil nil))) - (dformat 3 "read ~S ~S~%" ch num) - (mapc #'xlib:destroy-window wins) - (clear-frame-outlines group) - (find ch (group-frames group) - :test 'char= - :key 'get-frame-number-translation))) - - (defcommand fselect (frame-number) ((:frame t)) "Display a number in the corner of each frame and let the user to select a frame by number. If @var{frame-number} is specified, just @@ -736,565 +383,6 @@ jump to that frame." (let ((group (current-group))) (focus-frame group frame-number))) -(defcommand resize (width height) ((:number "+ Width: ") - (:number "+ Height: ")) - "Resize the current frame by @var{width} and @var{height} pixels" - (let* ((group (current-group)) - (f (tile-group-current-frame group))) - (if (atom (tile-group-frame-tree group)) - (message "No more frames!") - (progn - (clear-frame-outlines group) - (resize-frame group f width :width) - (resize-frame group f height :height) - (draw-frame-outlines group (current-head)))))) - -(defcommand eval-line (cmd) ((:rest "Eval: ")) - (handler-case - (message "^20~{~a~^~%~}" - (mapcar 'prin1-to-string - (multiple-value-list (eval (read-from-string cmd))))) - (error (c) - (err "^B^1*~A" c)))) - -(defcommand-alias eval eval-line) - -(defcommand echo (string) ((:rest "Echo: ")) - "Display @var{string} in the message bar." - ;; The purpose of echo is always to pop up a message window. - (let ((*executing-stumpwm-command* nil)) - (message "~a" string))) - -;; Simple command & arg parsing -(defun split-by-one-space (string) - "Returns a list of substrings of string divided by ONE space each. -Note: Two consecutive spaces will be seen as if there were an empty -string between them." - (loop for i = 0 then (1+ j) - as j = (position #\Space string :start i) - collect (subseq string i j) - while j)) - -(defstruct argument-line - string start) - -(defvar *command-type-hash* (make-hash-table) - "A hash table of types and functions to deal with these types.") - -(defun argument-line-end-p (input) - "Return T if we're outta arguments from the input line." - (>= (argument-line-start input) - (length (argument-line-string input)))) - -(defun argument-pop (input) - "Pop the next argument off." - (unless (argument-line-end-p input) - (let* ((p1 (position-if-not (lambda (ch) - (char= ch #\Space)) - (argument-line-string input) - :start (argument-line-start input))) - (p2 (or (and p1 (position #\Space (argument-line-string input) :start p1)) - (length (argument-line-string input))))) - (prog1 - ;; we wanna return nil if they're the same - (unless (= p1 p2) - (subseq (argument-line-string input) p1 p2)) - (setf (argument-line-start input) (1+ p2)))))) - -(defun argument-pop-or-read (input prompt &optional completions) - (or (argument-pop input) - (if completions - (completing-read (current-screen) prompt completions) - (read-one-line (current-screen) prompt)) - (throw 'error :abort))) - -(defun argument-pop-rest (input) - "Return the remainder of the argument text." - (unless (argument-line-end-p input) - (prog1 - (subseq (argument-line-string input) (argument-line-start input)) - (setf (argument-line-start input) (length (argument-line-string input)))))) - -(defun argument-pop-rest-or-read (input prompt &optional completions) - (or (argument-pop-rest input) - (if completions - (completing-read (current-screen) prompt completions) - (read-one-line (current-screen) prompt)) - (throw 'error :abort))) - -(defmacro define-stumpwm-type (type (input prompt) &body body) - `(setf (gethash ,type *command-type-hash*) - (lambda (,input ,prompt) - ,@body))) - -(defun lookup-symbol (string) - ;; FIXME: should we really use string-upcase? - (let* ((ofs (split-string string ":")) - (pkg (if (> (length ofs) 1) - (find-package (string-upcase (pop ofs))) - *package*)) - (var (string-upcase (pop ofs))) - (ret (find-symbol var pkg))) - (when (plusp (length ofs)) - (throw 'error "Too many :'s")) - (if ret - (values ret pkg var) - (throw 'error (format nil "No such symbol: ~a::~a." - (package-name pkg) var))))) - -(define-stumpwm-type :y-or-n (input prompt) - (let ((s (or (argument-pop input) - (read-one-line (current-screen) (concat prompt "(y/n): "))))) - (when s - (values (list (equal s "y")))))) - -(define-stumpwm-type :variable (input prompt) - (lookup-symbol (argument-pop-or-read input prompt))) - -(define-stumpwm-type :function (input prompt) - (multiple-value-bind (sym pkg var) - (lookup-symbol (argument-pop-or-read input prompt)) - (if (symbol-function sym) - (symbol-function sym) - (throw 'error (format nil "the symbol ~a::~a has no function." - (package-name pkg) var))))) - -(define-stumpwm-type :command (input prompt) - (or (argument-pop input) - (string-trim " " - (completing-read (current-screen) - prompt - (all-commands))))) - -(define-stumpwm-type :key-seq (input prompt) - (labels ((update (seq) - (message "~a: ~{~a ~}" - prompt - (mapcar 'print-key (reverse seq))))) - (let ((rest (argument-pop-rest input))) - (or (and rest (parse-key-seq rest)) - ;; read a key sequence from the user - (with-focus (screen-key-window (current-screen)) - (message "~a" prompt) - (nreverse (second (multiple-value-list - (read-from-keymap *top-map* #'update))))))))) - -(define-stumpwm-type :window-number (input prompt) - (let ((n (or (argument-pop input) - (completing-read (current-screen) - prompt - (mapcar 'prin1-to-string - (mapcar 'window-number - (group-windows (current-group)))))))) - (when n - (handler-case - (parse-integer n) - (parse-error (c) - (declare (ignore c)) - (throw 'error "Number required.")))))) - -(define-stumpwm-type :number (input prompt) - (let ((n (or (argument-pop input) - (read-one-line (current-screen) prompt)))) - (when n - (handler-case - (parse-integer n) - (parse-error (c) - (declare (ignore c)) - (throw 'error "Number required.")))))) - - -(define-stumpwm-type :string (input prompt) - (or (argument-pop input) - (read-one-line (current-screen) prompt))) - -(define-stumpwm-type :key (input prompt) - (let ((s (or (argument-pop input) - (read-one-line (current-screen) prompt)))) - (when s - (kbd s)))) - -(define-stumpwm-type :window-name (input prompt) - (or (argument-pop input) - (completing-read (current-screen) prompt - (mapcar 'window-name - (group-windows (current-group)))))) - -(define-stumpwm-type :gravity (input prompt) -"Set the current window's gravity." - (let* ((values '(("center" :center) - ("top" :top) - ("right" :right) - ("bottom" :bottom) - ("left" :left) - ("top-right" :top-right) - ("top-left" :top-left) - ("bottom-right" :bottom-right) - ("bottom-left" :bottom-left))) - (gravity (second (assoc (string-trim " " (argument-pop-or-read input prompt values)) values :test 'string-equal)))) - (or gravity - (throw 'error "No matching gravity.")))) - -(defun select-group (screen query) - "Attempt to match string QUERY against group number or partial name." - (let (match - (num (ignore-errors (parse-integer query)))) - (labels ((match (grp) - (let* ((name (group-name grp)) - (end (min (length name) (length query)))) - ;; try by name or number - (or (string-equal name query :end1 end :end2 end) - (eql (group-number grp) num))))) - (unless (null query) - (setf match (find-if #'match (screen-groups screen)))) - match))) - -(define-stumpwm-type :group (input prompt) - (let ((match (select-group (current-screen) - (or (argument-pop input) - (completing-read (current-screen) prompt - (mapcar 'group-name - (screen-groups (current-screen)))))))) - (or match - (throw 'error "No Such Group.")))) - -(define-stumpwm-type :frame (input prompt) - (declare (ignore prompt)) - (let ((arg (argument-pop input))) - (if arg - (or (find arg (group-frames (current-group)) - :key (lambda (f) - (string (get-frame-number-translation f))) - :test 'string=) - (throw 'error "Frame not found.")) - (or (choose-frame-by-number (current-group)) - (throw 'error :abort))))) - -(define-stumpwm-type :shell (input prompt) - (or (argument-pop-rest input) - (completing-read (current-screen) prompt 'programs-in-path))) - -(define-stumpwm-type :rest (input prompt) - (or (argument-pop-rest input) - (read-one-line (current-screen) prompt))) - -(defvar *max-command-alias-depth* 10 - "") - -(defun get-command-symbol (command) - (if (stringp command) - (find-symbol (string-upcase command) :stumpwm) - command)) - -(defun get-command-structure (command) - "Return the command structure for COMMAND." - (declare (type (or string symbol) command)) - (setf command (get-command-symbol command)) - (and command - (loop for c = (gethash command *command-hash*) - for depth from 1 - until (or (null c) - (command-p c)) - ;; the only other possibility is an alias - do (setf command (command-alias-to c)) - (when (> depth *max-command-alias-depth*) - (error "Maximum command alias depth exceded")) - finally (return c)))) - -(defun call-interactively (command &optional (input "")) - "Parse the command's arguments from inputgiven the command's -argument specifications then execute it. Returns a string or nil if -user aborted." - (declare (type (or string symbol) command) - (type (or string argument-line) input)) - ;; Catch parse errors - (catch 'error - (let* ((arg-line (if (stringp input) - (make-argument-line :string input - :start 0) - input)) - (cmd-data (or (get-command-structure command) - (throw 'error (format nil "Command '~a' not found." command)))) - (arg-specs (command-args cmd-data)) - (args (loop for spec in arg-specs - collect (let* ((type (if (listp spec) - (first spec) - spec)) - (prompt (when (listp spec) - (second spec))) - (fn (gethash type *command-type-hash*))) - (unless fn - (throw 'error (format nil "Bad argument type: ~s" type))) - ;; If the prompt is NIL then it's - ;; considered an optional argument and - ;; we shouldn't prompt for it if the - ;; arg line is empty. - (if (and (null prompt) - (argument-line-end-p arg-line)) - (loop-finish) - ;; FIXME: Is it presumptuous to assume NIL means abort? - (or (funcall fn arg-line prompt) - (throw 'error :abort))))))) - ;; Did the whole string get parsed? - (unless (or (argument-line-end-p arg-line) - (position-if 'alphanumericp (argument-line-string arg-line) :start (argument-line-start arg-line))) - (throw 'error (format nil "Trailing garbage: ~{~A~^ ~}" (subseq (argument-line-string arg-line) - (argument-line-start arg-line))))) - ;; Success - (prog1 - (apply (command-name cmd-data) args) - (setf *last-command* command))))) - -(defun interactive-command (cmd) - "exec cmd and echo the result." - (labels ((parse-and-run-command (input) - (let* ((arg-line (make-argument-line :string input - :start 0)) - (cmd (argument-pop arg-line))) - (call-interactively cmd arg-line)))) - (multiple-value-bind (result error-p) - ;; this fancy footwork lets us grab the backtrace from where the - ;; error actually happened. - (restart-case - (handler-bind - ((error (lambda (c) - (invoke-restart 'interactive-command-error - (format nil "^B^1*Error In Command '^b~a^B': ^n~A~a" - cmd c (if *show-command-backtrace* - (backtrace-string) "")))))) - (parse-and-run-command cmd)) - (interactive-command-error (err-text) - (values err-text t))) - ;; interactive commands update the modeline - (update-all-mode-lines) - (cond ((stringp result) - (if error-p - (message-no-timeout "~a" result) - (message "~a" result))) - ((eq result :abort) - (unless *suppress-abort-messages* - (message "Abort."))))))) - -(defcommand colon (&optional initial-input) (:rest) - "Read a command from the user. @var{initial-text} is optional. When -supplied, the text will appear in the prompt." - (let ((cmd (completing-read (current-screen) ": " (all-commands) (or initial-input "")))) - (unless cmd - (throw 'error :abort)) - (when (plusp (length cmd)) - (interactive-command cmd)))) - -(defcommand pull-window-by-number (n &optional (group (current-group))) - ((:window-number "Pull: ")) - "Pull window N from another frame into the current frame and focus it." - (let ((win (find n (group-windows group) :key 'window-number :test '=))) - (when win - (pull-window win)))) - -(defcommand-alias pull pull-window-by-number) - -(defun send-meta-key (screen key) - "Send the prefix key" - (when (screen-current-window screen) - (send-fake-key (screen-current-window screen) key))) - -(defcommand meta (key) ((:key "Key: ")) -"Send a fake key to the current window. @var{key} is a typical StumpWM key, like @kbd{C-M-o}." - (send-meta-key (current-screen) key)) - -(defcommand renumber (nt &optional (group (current-group))) ((:number "Number: ")) - "Change the current window's number to the specified number. If another window -is using the number, then the windows swap numbers. Defaults to current group." - (let ((nf (window-number (group-current-window group))) - (win (find-if #'(lambda (win) - (= (window-number win) nt)) - (group-windows group)))) - ;; Is it already taken? - (if win - (progn - ;; swap the window numbers - (setf (window-number win) nf) - (setf (window-number (group-current-window group)) nt)) - ;; Just give the window the number - (setf (window-number (group-current-window group)) nt)))) - -(defcommand-alias number renumber) - -(defcommand gravity (gravity) ((:gravity "Gravity: ")) - (when (current-window) - (setf (window-gravity (current-window)) gravity) - (maximize-window (current-window)))) - -(defcommand loadrc () () -"Reload the @file{~/.stumpwmrc} file." - (handler-case - (progn - (with-restarts-menu (load-rc-file nil))) - (error (c) - (message "^1*^BError loading rc file: ^n~A" c)) - (:no-error (&rest args) - (declare (ignore args)) - (message "rc file loaded successfully.")))) - -(defun columnize (list columns &key col-aligns (pad 1) (char #\Space) (align :left)) - ;; only somewhat nasty - (let* ((rows (truncate (length list) columns)) - (data (loop for i from 0 below (length list) by rows - collect (subseq list i (min (+ i rows) (length list))))) - (max (mapcar (lambda (col) - (reduce 'max col :key 'length :initial-value 0)) - data)) - (padstr (make-string pad :initial-element char))) - (apply 'mapcar 'concat - ;; normalize width - (loop - for i in data - for j in max - for c from 0 - collect (loop - for k from 0 below rows - for s = (or (nth k i) "") - for len = (make-string (- j (length s)) - :initial-element char) - collect (ecase (or (nth c col-aligns) align) - (:left (format nil "~a~a~a" (if (= c 0) "" padstr) s len)) - (:right (format nil "~a~a~a" (if (= c 0) "" padstr) len s)))))))) - -(defun display-keybinding (kmap-var) - (let* ((screen (current-screen)) - (data (mapcar-hash (lambda (k v) (format nil "^5*~5a^n ~a" (print-key k) v)) (symbol-value kmap-var))) - (cols (ceiling (length data) - (truncate (- (head-height (current-head)) (* 2 (screen-msg-border-width screen))) - (font-height (screen-font screen)))))) - (message-no-timeout "Prefix: ~{~a~^ | ~}~%~{~a~^~%~}" - (mapcar 'print-key-seq (search-kmap kmap-var *top-map*)) - (columnize data cols)))) - -(defcommand help () () -"Display all the bindings in @var{*root-map*}." - (display-keybinding '*root-map*)) - -(defcommand commands () () - (let* ((screen (current-screen)) - (data (all-commands)) - (cols (ceiling (length data) - (truncate (head-height (current-head)) - (font-height (screen-font screen)))))) - (message-no-timeout "~{~a~^~%~}" - (columnize data cols)))) - -(defcommand keyboard-quit () () - "" - ;; This way you can exit from command mode - (when (pop-top-map) - (message "Exited."))) - -(defcommand-alias abort keyboard-quit) - -(defun set-prefix-key (key) - "Change the stumpwm prefix key to KEY. address@hidden -\(stumpwm:set-prefix-key (stumpwm:kbd \"C-M-H-s-z\")) address@hidden example - -This will change the prefix key to @key{Control} + @key{Meta} + @key{Hyper} + @key{Super} + -the @key{z} key. By most standards, a terrible prefix key but it makes a -great example." - (check-type key key) - (let (prefix) - (dolist (i (lookup-command *top-map* '*root-map*)) - (setf prefix i) - (undefine-key *top-map* i)) - (define-key *top-map* key '*root-map*) - (let* ((meta (make-key :keysym (key-keysym key))) - (old-cmd (concatenate 'string "meta " (print-key prefix))) - (cmd (concatenate 'string "meta " (print-key key)))) - (dolist (i (lookup-command *root-map* old-cmd)) - (undefine-key *root-map* i)) - (define-key *root-map* meta cmd)) - (define-key *root-map* key "other") - (sync-keys))) - -(defcommand quit () () -"Quit StumpWM." - (throw :top-level :quit)) - -(defcommand soft-restart () () - "Soft Restart StumpWM. The lisp process isn't restarted. Instead, -control jumps to the very beginning of the stumpwm program. This -differs from a theoretical hard restart, which would restart the unix -process." - (throw :top-level :restart)) - -(defun clear-frame (frame group) - "Clear the given frame." - (frame-raise-window group frame nil (eq (tile-group-current-frame group) frame))) - -(defcommand fclear () () -"Clear the current frame." - (clear-frame (tile-group-current-frame (current-group)) (current-group))) - -(defun get-edge (frame edge) - "Returns the specified edge of FRAME. Valid values for EDGE are :TOP, :BOTTOM, :LEFT, and :RIGHT. - An edge is a START, END, and OFFSET. For horizontal edges, START is the left coordinate, END is - the right coordinate, and OFFSET is the Y coordinate. Similarly, for vertical lines, START is - top, END is bottom, and OFFSET is X coordinate." - (let* ((x1 (frame-x frame)) - (y1 (frame-y frame)) - (x2 (+ x1 (frame-width frame))) - (y2 (+ y1 (frame-height frame)))) - (ecase edge - (:top - (values x1 x2 y1)) - (:bottom - (values x1 x2 y2)) - (:left - (values y1 y2 x1)) - (:right - (values y1 y2 x2))))) - -(defun neighbour (direction frame frameset) - "Returns the best neighbour of FRAME in FRAMESET on the DIRECTION edge. - Valid directions are :UP, :DOWN, :LEFT, :RIGHT. - eg: (NEIGHBOUR :UP F FS) finds the frame in FS that is the 'best' - neighbour above F." - (let ((src-edge (ecase direction - (:up :top) - (:down :bottom) - (:left :left) - (:right :right))) - (opposite (ecase direction - (:up :bottom) - (:down :top) - (:left :right) - (:right :left))) - (best-frame nil) - (best-overlap 0)) - (multiple-value-bind (src-s src-e src-offset) - (get-edge frame src-edge) - (dolist (f frameset) - (multiple-value-bind (s e offset) - (get-edge f opposite) - (let ((overlap (- (min src-e e) - (max src-s s)))) - ;; Two edges are neighbours if they have the same offset and their starts and ends - ;; overlap. We want to find the neighbour that overlaps the most. - (when (and (= src-offset offset) - (>= overlap best-overlap)) - (setf best-frame f) - (setf best-overlap overlap)))))) - best-frame)) - -(defun move-focus-and-or-window (dir &optional win-p) - (let* ((group (current-group)) - (direction (intern (string-upcase dir) :keyword)) - (new-frame (neighbour direction (tile-group-current-frame group) (group-frames group))) - (window (current-window))) - (when new-frame - (if (and win-p window) - (pull-window window new-frame) - (focus-frame group new-frame))))) - (defcommand move-focus (dir) ((:string "Direction: ")) "Focus the frame adjacent to the current one in the specified direction. The following are valid directions: @@ -1310,205 +398,42 @@ direction. The following are valid directions: "Just like move-focus except that the current is pulled along." (move-focus-and-or-window dir t)) -(defun run-or-raise (cmd props &optional (all-groups *run-or-raise-all-groups*) (all-screens *run-or-raise-all-screens*)) - "Run the shell command, @var{cmd}, unless an existing window -matches @var{props}. @var{props} is a property list with the following keys: - address@hidden @code address@hidden :class -Match the window's class. address@hidden :instance -Match the window's instance or resource-name. address@hidden :role -Match the window's @code{WM_WINDOW_ROLE}. address@hidden :title -Match the window's title. address@hidden table - -By default, the global @var{*run-or-raise-all-groups*} decides whether -to search all groups or the current one for a running -instance. @var{all-groups} overrides this default. Similarily for address@hidden and @var{all-screens}." - (labels - ;; Raise the window win and select its frame. For now, it - ;; does not select the screen. - ((goto-win (win) - (let* ((group (window-group win)) - (frame (window-frame win)) - (old-frame (tile-group-current-frame group))) - (frame-raise-window group frame win) - (focus-all win) - (unless (eq frame old-frame) - (show-frame-indicator group)))) - (find-window (group) - (find-if (lambda (w) - (apply 'window-matches-properties-p w props)) - (group-windows group)))) - (let* - ((screens (if all-screens - *screen-list* - (list (current-screen)))) - (win - ;; If no qualifiers are set don't bother looking for a match. - ;; search all groups - (if all-groups - (loop named outer - for s in screens - do (loop - for g in (screen-groups s) - for win = (find-window g) - when win - do (return-from outer win))) - (find-window (current-group))))) - (if win - (goto-win win) - (run-shell-command cmd))))) - -(defcommand escape (key) ((:string "Key: ")) - "Set the prefix key. Here's how you would change the prefix key to @kbd{C-z}. - address@hidden -escape C-z address@hidden example" - (set-prefix-key (kbd key))) - -(defvar *lastmsg-nth* nil) - -(defcommand lastmsg () () - ;; Allow the user to go back through the message history - (if (string= *last-command* "lastmsg") - (progn - (incf *lastmsg-nth*) - (if (>= *lastmsg-nth* (length (screen-last-msg (current-screen)))) - (setf *lastmsg-nth* 0))) - (setf *lastmsg-nth* 0)) - (if (screen-last-msg (current-screen)) - (echo-nth-last-message (current-screen) *lastmsg-nth*) - (message "No last message."))) - -;;; A resize minor mode. Something a bit better should probably be -;;; written. But it's an interesting way of doing it. - -(defvar *resize-backup* nil) - -(defvar *resize-increment* 10 - "Number of pixels to increment by when interactively resizing frames.") - -(defun set-resize-increment (val) - (setf *resize-increment* val) - (update-resize-map)) - -(defun update-resize-map () - (let ((m (or *resize-map* (setf *resize-map* (make-sparse-keymap))))) - (let ((i *resize-increment*)) - (labels ((dk (m k c) - (define-key m k (format nil c i)))) - (dk m (kbd "Up") "resize 0 -~D") - (dk m (kbd "C-p") "resize 0 -~D") - (dk m (kbd "p") "resize 0 -~D") - (dk m (kbd "k") "resize 0 -~D") - - (dk m (kbd "Down") "resize 0 ~D") - (dk m (kbd "C-n") "resize 0 ~D") - (dk m (kbd "n") "resize 0 ~D") - (dk m (kbd "j") "resize 0 ~D") - - (dk m (kbd "Left") "resize -~D 0") - (dk m (kbd "C-b") "resize -~D 0") - (dk m (kbd "b") "resize -~D 0") - (dk m (kbd "h") "resize -~D 0") - - (dk m (kbd "Right") "resize ~D 0") - (dk m (kbd "C-f") "resize ~D 0") - (dk m (kbd "f") "resize ~D 0") - (dk m (kbd "l") "resize ~D 0") - (define-key m (kbd "RET") "exit-iresize") - (define-key m (kbd "C-g") "abort-iresize") - (define-key m (kbd "ESC") "abort-iresize"))))) +(defcommand next-in-frame () () +"Go to the next window in the current frame." + (let ((group (current-group))) + (if (group-current-window group) + (focus-forward group (frame-sort-windows group (tile-group-current-frame group))) + (other-window-in-frame group)))) -(update-resize-map) +(defcommand prev-in-frame () () +"Go to the previous window in the current frame." + (let ((group (current-group))) + (if (group-current-window group) + (focus-forward group (reverse (frame-sort-windows group (tile-group-current-frame group)))) + (other-window-in-frame group)))) -(defcommand iresize () () - (let ((frame (tile-group-current-frame (current-group)))) - (if (atom (tile-group-frame-head (current-group) (frame-head (current-group) frame))) - (message "There's only 1 frame!") - (progn - (when *resize-hides-windows* - (dolist (f (head-frames (current-group) (current-head))) - (clear-frame f (current-group)))) - (message "Resize Frame") - (push-top-map *resize-map*) - (draw-frame-outlines (current-group) (current-head))) - ;; (setf *resize-backup* (copy-frame-tree (current-group))) - ))) +(defcommand other-in-frame () () +"Go to the last accessed window in the current frame." + (other-window-in-frame (current-group))) -(defun resize-unhide () - (clear-frame-outlines (current-group)) - (when *resize-hides-windows* - (let ((group (current-group)) - (head (current-head))) - (dolist (f (head-frames group head)) - (sync-frame-windows group f)) - (dolist (w (reverse (head-windows group head))) - (setf (frame-window (window-frame w)) w) - (raise-window w)) - (when (current-window) - (focus-window (current-window)))))) +;;; ------------------------------------------------------------------ +;;; Fullscreen & Gravity +;;; ------------------------------------------------------------------ -(defcommand abort-iresize () () - (resize-unhide) - (message "Abort resize") - ;; TODO: actually revert the frames - (pop-top-map)) +(defcommand fullscreen () () + "Toggle the fullscreen mode of the current window. Use this for clients +with broken (non-NETWM) fullscreen implementations, such as any program +using SDL." + (update-fullscreen (current-window) 2)) -(defcommand exit-iresize () () - (resize-unhide) - (message "Resize Complete") - (pop-top-map)) +(defcommand gravity (gravity) ((:gravity "Gravity: ")) + (when (current-window) + (setf (window-gravity (current-window)) gravity) + (maximize-window (current-window)))) -;;; group commands - -;; FIXME: groups are to screens exactly as windows are to -;; groups. There is a lot of duplicate code that could be globbed -;; together. - -(defvar *groups-map* nil - "The keymap that group related key bindings sit on. It is bound to @kbd{C-t g} by default.") - -(when (null *groups-map*) - (setf *groups-map* - (let ((m (make-sparse-keymap))) - (define-key m (kbd "g") "groups") - (define-key m (kbd "c") "gnew") - (define-key m (kbd "n") "gnext") - (define-key m (kbd "C-n") "gnext") - (define-key m (kbd "SPC") "gnext") - (define-key m (kbd "C-SPC") "gnext") - (define-key m (kbd "p") "gprev") - (define-key m (kbd "C-p") "gprev") - (define-key m (kbd "o") "gother") - (define-key m (kbd "'") "gselect") - (define-key m (kbd "m") "gmove") - (define-key m (kbd "M") "gmove-marked") - (define-key m (kbd "k") "gkill") - (define-key m (kbd "A") "grename") - (define-key m (kbd "r") "grename") - (define-key m (kbd "1") "gselect 1") - (define-key m (kbd "2") "gselect 2") - (define-key m (kbd "3") "gselect 3") - (define-key m (kbd "4") "gselect 4") - (define-key m (kbd "5") "gselect 5") - (define-key m (kbd "6") "gselect 6") - (define-key m (kbd "7") "gselect 7") - (define-key m (kbd "8") "gselect 8") - (define-key m (kbd "9") "gselect 9") - (define-key m (kbd "0") "gselect 10") - m))) - -(defun group-forward (current list) - (let ((ng (next-group current list))) - (when ng - (switch-to-group ng)))) +;;; ------------------------------------------------------------------ +;;; Groups +;;; ------------------------------------------------------------------ (defcommand gnew (name) ((:string "Group Name: ")) "Create a new group with the specified name. The new group becomes the @@ -1559,21 +484,6 @@ groups and vgroups commands." (setf (group-number group) (find-free-group-number (current-screen))))) (setf (group-name group) name))))) -(defun echo-groups (screen fmt &optional verbose (wfmt *window-format*)) - "Print a list of the windows to the screen." - (let* ((groups (sort-groups screen)) - (names (mapcan (lambda (g) - (list* - (format-expand *group-formatters* fmt g) - (when verbose - (mapcar (lambda (w) - (format-expand *window-formatters* - (concatenate 'string " " wfmt) - w)) - (sort-windows g))))) - (if *list-hidden-groups* groups (non-hidden-groups groups))))) - (echo-string-list screen names))) - (defcommand groups (&optional (fmt *group-format*)) (:rest) "Display the list of groups with their number and name. @var{*group-format*} controls the formatting. The optional @@ -1623,88 +533,189 @@ to the next group." (message "^B^3*Cannot merge group with itself!") (merge-groups from (current-group)))) -;;; interactive menu - -(defvar *menu-map* nil - "The keymap used by the interactive menu.") - -(when (null *menu-map*) - (setf *menu-map* - (let ((m (make-sparse-keymap))) - (define-key m (kbd "C-p") 'menu-up) - (define-key m (kbd "Up") 'menu-up) - (define-key m (kbd "k") 'menu-up) - - (define-key m (kbd "C-n") 'menu-down) - (define-key m (kbd "Down") 'menu-down) - (define-key m (kbd "j") 'menu-down) - (define-key m (kbd "C-g") 'menu-abort) - (define-key m (kbd "ESC") 'menu-abort) - (define-key m (kbd "RET") 'menu-finish) - m))) - -(defstruct menu-state - table prompt selected) - -(defun bound-check-menu (menu) - (setf (menu-state-selected menu) - (cond ((< (menu-state-selected menu) 0) - (1- (length (menu-state-table menu)))) - ((>= (menu-state-selected menu) (length (menu-state-table menu))) - 0) - (t (menu-state-selected menu))))) - -(defun menu-up (menu) - (decf (menu-state-selected menu)) - (bound-check-menu menu)) - -(defun menu-down (menu) - (incf (menu-state-selected menu)) - (bound-check-menu menu)) - -(defun menu-finish (menu) - (throw :menu-quit (nth (menu-state-selected menu) (menu-state-table menu)))) - -(defun menu-abort (menu) - (declare (ignore menu)) - (throw :menu-quit nil)) - -(defun select-from-menu (screen table &optional prompt (initial-selection 0)) - "Prompt the user to select from a menu on SCREEN. TABLE can be -a list of values or an alist. If it's an alist, the CAR of each -element is displayed in the menu. What is displayed as menu items -must be strings. Returns the selected element in TABLE or nil if aborted. - -See *menu-map* for menu bindings." - (check-type screen screen) - (check-type table list) - (check-type prompt (or null string)) - (check-type initial-selection integer) - (let* ((menu (make-menu-state - :table table - :prompt prompt - :selected initial-selection)) - (menu-options (mapcar (lambda (elt) - (if (listp elt) - (first elt) - elt)) - table)) - (menu-text (if prompt - (cons prompt menu-options) - menu-options)) - (*record-last-msg-override* t) - (*suppress-echo-timeout* t)) - (bound-check-menu menu) - (catch :menu-quit - (unwind-protect - (with-focus (screen-key-window screen) - (loop - (echo-string-list screen menu-text - (+ (menu-state-selected menu) (if prompt 1 0))) - (let ((action (read-from-keymap *menu-map*))) - (when action - (funcall action menu))))) - (unmap-all-message-windows))))) +;;; ------------------------------------------------------------------ +;;; Selection +;;; ------------------------------------------------------------------ + +(defcommand insert (string) ((:rest "Insert: ")) +"Send the string of characters to the current window as if they'd been typed." + (window-send-string (current-window) string)) + +(defcommand putsel (string) ((:rest "Text: ")) +"Stuff the string @var{string} into the X selection." + (set-x-selection string)) + +;; FIXME: this function is basically useless atm. +(defcommand getsel () () +"Echo the X selection." + (message "~a" (get-x-selection))) + +;;; ------------------------------------------------------------------ +;;; Frame dumping & restoring +;;; ------------------------------------------------------------------ + +(defcommand dump-group-to-file (file) ((:rest "Dump To File: ")) + "Dumps the frames of the current group of the current screen to the named file." + (dump-to-file (dump-group (current-group)) file) + (message "Group dumped")) + +(defcommand-alias dump-group dump-group-to-file) + +(defcommand dump-screen-to-file (file) ((:rest "Dump To File: ")) + "Dumps the frames of all groups of the current screen to the named file" + (dump-to-file (dump-screen (current-screen)) file) + (message "Screen dumped")) + +(defcommand-alias dump-screen dump-screen-to-file) + +(defcommand dump-desktop-to-file (file) ((:rest "Dump To File: ")) + "Dumps the frames of all groups of all screens to the named file" + (dump-to-file (dump-desktop) file) + (message "Desktop dumped")) + +(defcommand-alias dump-desktop dump-desktop-to-file) + +(defcommand restore (file) ((:rest "Restore From File: ")) + "Restores screen, groups, or frames from named file, depending on file's contents." + (restore-from-file file)) + +(defcommand place-existing-windows () () + (sync-window-placement)) + +;;; ------------------------------------------------------------------ +;;; Resizing things +;;; ------------------------------------------------------------------ + +(defcommand resize (width height) ((:number "+ Width: ") + (:number "+ Height: ")) + "Resize the current frame by @var{width} and @var{height} pixels" + (let* ((group (current-group)) + (f (tile-group-current-frame group))) + (if (atom (tile-group-frame-tree group)) + (message "No more frames!") + (progn + (clear-frame-outlines group) + (resize-frame group f width :width) + (resize-frame group f height :height) + (draw-frame-outlines group (current-head)))))) + +(defcommand balance-frames () () + "Make frames the same height or width in the current frame's subtree." + (let* ((group (current-group)) + (tree (tree-parent (tile-group-frame-head group (current-head)) + (tile-group-current-frame group)))) + (if tree + (balance-frames-internal (current-group) tree) + (message "There's only one frame.")))) + +(defcommand iresize () () + (let ((frame (tile-group-current-frame (current-group)))) + (if (atom (tile-group-frame-head (current-group) (frame-head (current-group) frame))) + (message "There's only 1 frame!") + (progn + (when *resize-hides-windows* + (dolist (f (head-frames (current-group) (current-head))) + (clear-frame f (current-group)))) + (message "Resize Frame") + (push-top-map *resize-map*) + (draw-frame-outlines (current-group) (current-head))) + ;; (setf *resize-backup* (copy-frame-tree (current-group))) + ))) + +(defcommand abort-iresize () () + (resize-unhide) + (message "Abort resize") + ;; TODO: actually revert the frames + (pop-top-map)) + +(defcommand exit-iresize () () + (resize-unhide) + (message "Resize Complete") + (pop-top-map)) + +;;; ------------------------------------------------------------------ +;;; Windows +;;; ------------------------------------------------------------------ + +(defcommand next () () + "Go to the next window in the window list." + (let ((group (current-group))) + (if (group-current-window group) + (focus-next-window group) + (other-window group)))) + +(defcommand prev () () + "Go to the previous window in the window list." + (let ((group (current-group))) + (if (group-current-window group) + (focus-prev-window group) + (other-window group)))) + +(defcommand pull-window-by-number (n &optional (group (current-group))) + ((:window-number "Pull: ")) + "Pull window N from another frame into the current frame and focus it." + (let ((win (find n (group-windows group) :key 'window-number :test '=))) + (when win + (pull-window win)))) + +(defcommand-alias pull pull-window-by-number) + +(defcommand delete-current-window () () + "Delete the current window. This is a request sent to the window. The +window's client may decide not to grant the request or may not be able +to if it is unresponsive." + (let ((group (current-group))) + (when (group-current-window group) + (delete-window (group-current-window group))))) + +(defcommand-alias delete delete-current-window) + +(defcommand kill-current-window () () +"`Tell X to disconnect the client that owns the current window. if address@hidden didn't work, try this." + (let ((group (current-group))) + (when (group-current-window group) + (xwin-kill (window-xwin (group-current-window group)))))) + +(defcommand-alias kill kill-current-window) + +(defcommand windows (&optional (fmt *window-format*)) (:rest) + "Display a list of managed windows. The optional argument @var{fmt} can +be used to override the default window formatting." + (echo-windows (current-group) fmt)) + +(defcommand echo-frame-windows (&optional (fmt *window-format*)) (:rest) + (echo-windows (current-group) fmt (frame-windows (current-group) + (tile-group-current-frame (current-group))))) + +(defcommand-alias frame-windows echo-frame-windows) + +(defcommand title (title) ((:rest "Set window's title to: ")) + (if (current-window) + (setf (window-user-title (current-window)) title) + (message "No Focused Window"))) + +(defcommand renumber (nt &optional (group (current-group))) ((:number "Number: ")) + "Change the current window's number to the specified number. If another window +is using the number, then the windows swap numbers. Defaults to current group." + (let ((nf (window-number (group-current-window group))) + (win (find-if #'(lambda (win) + (= (window-number win) nt)) + (group-windows group)))) + ;; Is it already taken? + (if win + (progn + ;; swap the window numbers + (setf (window-number win) nf) + (setf (window-number (group-current-window group)) nt)) + ;; Just give the window the number + (setf (window-number (group-current-window group)) nt)))) + +(defcommand-alias number renumber) + +(defcommand select (win) ((:window-name "Select: ")) + "Switch to the first window that starts with @var{win}." + (select-window (current-group) win)) (defcommand windowlist (&optional (fmt *window-format*)) (:rest) "Allow the user to Select a window from the list of windows and focus @@ -1724,96 +735,9 @@ override the default window formatting." (frame-raise-window group (window-frame window) window) (throw 'error :abort))))) -(defcommand reload () () -"Reload StumpWM using @code{asdf}." - (message "Reloading StumpWM...") - #+asdf (with-restarts-menu - (asdf:operate 'asdf:load-op :stumpwm)) - #-asdf (message "^B^1*Sorry, StumpWM can only be reloaded with asdf (for now.)") - #+asdf (message "Reloading StumpWM...^B^2*Done^n.")) - -(defun run-commands (&rest commands) - "Run each stumpwm command in sequence. This could be used if you're -used to ratpoison's rc file and you just want to run commands or don't -know lisp very well. One might put the following in one's rc file: - address@hidden -\(stumpwm:run-commands - \"escape C-z\" - \"exec firefox\" - \"split\") address@hidden example" - (loop for i in commands do - (interactive-command i))) - -(defcommand snext () () -"Go to the next screen." - (switch-to-screen (next-screen)) - (show-frame-indicator (current-group))) - -(defcommand sprev () () -"Go to the previous screen." - (switch-to-screen (next-screen (reverse (sort-screens)))) - (show-frame-indicator (current-group))) - -(defcommand sother () () -"Go to the last screen." - (switch-to-screen (cadr *screen-list*)) - (show-frame-indicator (current-group))) - -(defun window-send-string (window string) - "Send the string of characters to the window as if they'd been typed." - (when window - (map nil (lambda (ch) - ;; exploit the fact that keysyms for ascii characters - ;; are the same as their ascii value. - (let ((sym (cond ((<= 32 (char-code ch) 127) - (char-code ch)) - ((char= ch #\Tab) - (stumpwm-name->keysym "TAB")) - ((char= ch #\Newline) - (stumpwm-name->keysym "RET")) - (t nil)))) - (when sym - (send-fake-key window - (make-key :keysym sym))))) - string))) - -(defcommand insert (string) ((:rest "Insert: ")) -"Send the string of characters to the current window as if they'd been typed." - (window-send-string (current-window) string)) - -(defcommand putsel (string) ((:rest "Text: ")) -"Stuff the string @var{string} into the X selection." - (set-x-selection string)) - -;; FIXME: this function is basically useless atm. -(defcommand getsel () () -"Echo the X selection." - (message "~a" (get-x-selection))) - -(defun other-hidden-window (group) - "Return the last window that was accessed and that is hidden." - (let ((wins (remove-if (lambda (w) (eq (frame-window (window-frame w)) w)) (group-windows group)))) - (first wins))) - -(defun pull-other-hidden-window (group) - "pull the last accessed hidden window from any frame into the -current frame and raise it." - (let ((win (other-hidden-window group))) - (if win - (pull-window win) - (echo-string (group-screen group) "No other window.")))) - -(defun other-window-in-frame (group) - (let* ((f (tile-group-current-frame group)) - (wins (frame-windows group f)) - (win (if (frame-window f) - (second wins) - (first wins)))) - (if win - (frame-raise-window group (window-frame win) win) - (echo-string (group-screen group) "No other window.")))) +(defcommand other () () + "Switch to the window last focused." + (other-window (current-group))) (defcommand pull-hidden-next () () "Pull the next hidden window into the current frame." @@ -1830,31 +754,6 @@ current frame and raise it." (let ((group (current-group))) (pull-other-hidden-window group))) -(defcommand next-in-frame () () -"Go to the next window in the current frame." - (let ((group (current-group))) - (if (group-current-window group) - (focus-forward group (frame-sort-windows group (tile-group-current-frame group))) - (other-window-in-frame group)))) - -(defcommand prev-in-frame () () -"Go to the previous window in the current frame." - (let ((group (current-group))) - (if (group-current-window group) - (focus-forward group (reverse (frame-sort-windows group (tile-group-current-frame group)))) - (other-window-in-frame group)))) - -(defcommand other-in-frame () () -"Go to the last accessed window in the current frame." - (other-window-in-frame (current-group))) - -(defcommand command-mode () () -"Command mode allows you to type ratpoison commands without needing the address@hidden prefix. Keys not bound in StumpWM will still get sent to the -current window. To exit command mode, type @key{C-g}." - (message "Press C-g to exit command-mode.") - (push-top-map *root-map*)) - (defcommand mark () () "Toggle the current window's mark." (let ((win (current-window))) @@ -1876,62 +775,6 @@ current window. To exit command mode, type @key{C-g}." (pull-window i)) (clear-window-marks group))) -(defcommand balance-frames () () - "Make frames the same height or width in the current frame's subtree." - (let* ((group (current-group)) - (tree (tree-parent (tile-group-frame-head group (current-head)) - (tile-group-current-frame group)))) - (if tree - (balance-frames-internal (current-group) tree) - (message "There's only one frame.")))) - -(defcommand describe-key (keys) ((:key-seq "Describe Key: ")) -"Either interactively type the key sequence or supply it as text. This -command prints the command bound to the specified key sequence." - (let ((cmd (lookup-key-sequence *top-map* keys))) - (if cmd - (message "~{~a~^ ~} is bound to \"~a\"." (mapcar 'print-key keys) cmd) - (message "~{~a~^ ~} is not bound." (mapcar 'print-key keys))))) - -(defcommand describe-variable (var) ((:variable "Describe Variable: ")) -"Print the online help associated with the specified variable." - (message-no-timeout "~a" - (with-output-to-string (s) - (describe var s)))) - -(defcommand describe-function (fn) ((:function "Describe Function: ")) -"Print the online help associated with the specified function." - (message-no-timeout "~a" - (with-output-to-string (s) - (describe fn s)))) - -(defcommand describe-command (com) ((:command "Describe Command: ")) - "Print the online help associated with the specified command." - (message-no-timeout "Command \"~a\":~%~a" com - (documentation (get-command-structure com) 'function))) - -(defcommand where-is (cmd) ((:rest "Where is command: ")) -"Print the key sequences bound to the specified command." - (message-no-timeout "\"~a\" is on ~{~a~^, ~}" - cmd - (mapcar 'print-key-seq (search-kmap cmd *top-map*)))) - - -;;; window placement commands - -(defun make-rule-for-window (window &optional lock title) - "Guess at a placement rule for WINDOW and add it to the current set." - (let* ((group (window-group window)) - (group-name (group-name group)) - (frame-number (frame-number (window-frame window))) - (role (window-role window))) - (push (list group-name frame-number t lock - :class (window-class window) - :instance (window-res window) - :title (and title (window-name window)) - :role (and (not (equal role "")) role)) - *window-placement-rules*))) - (defcommand remember (lock title) ((:y-or-n "Lock to group? ") (:y-or-n "Use title? ")) @@ -1947,38 +790,10 @@ command prints the command bound to the specified key sequence." (message "Rule forgotten")) (message "No matching rule")))) -(defun dump-window-placement-rules (file) - "Dump *window-placement-rules* to FILE." - (dump-to-file *window-placement-rules* file)) - (defcommand dump-rules (file) ((:rest "Filename: ")) (dump-window-placement-rules file)) -(defun restore-window-placement-rules (file) - "Restore *window-placement-rules* from FILE." - (setf *window-placement-rules* (read-dump-from-file file))) - (defcommand restore-rules (file) ((:rest "Filename: ")) (restore-window-placement-rules file)) -(defcommand emacs () () - "Start emacs unless it is already running, in which case focus it." - (run-or-raise "emacs" '(:class "Emacs"))) - -(defcommand bind (key command) - ((:text "Key Chord: ") - (:rest "Command: ")) - "Hang a key binding off the escape key." - (define-key *root-map* (kbd key) command)) - -(defcommand copy-unhandled-error () () - "When an unhandled error occurs, StumpWM restarts and attempts to -continue. Unhandled errors should be reported to the mailing list so -they can be fixed. Use this command to copy the unhandled error and -backtrace to the X11 selection so you can paste in your email when -submitting the bug report." - (if *last-unhandled-error* - (progn - (set-x-selection (format nil "~a~%~a" (first *last-unhandled-error*) (second *last-unhandled-error*))) - (message "Copied to clipboard.")) - (message "There was no unhandled error!"))) +;;; user.lisp ends here diff --git a/window.lisp b/window.lisp new file mode 100644 index 0000000..2ade183 --- /dev/null +++ b/window.lisp @@ -0,0 +1,178 @@ +;; Copyright (C) 2003, 2008 * +;; +;; This file is part of stumpwm. +;; +;; stumpwm is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; stumpwm is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA +;; +;; Commentary: +;; +;; Commands for manipulating windows, extracted from user.lisp. +;; +;; * user.lisp Copyright (C) 2003 Shawn Betts +;; +;; Code: + +;;; Window focus + +(in-package :stumpwm) + +(defun focus-next-window (group) + (focus-forward group (sort-windows group))) + +(defun focus-prev-window (group) + (focus-forward group + (reverse + (sort-windows group)))) + +(defun pull-window (win &optional (to-frame (tile-group-current-frame (window-group win)))) + (let ((f (window-frame win)) + (group (window-group win))) + (unless (eq (frame-window to-frame) win) + (xwin-hide win) + (setf (window-frame win) to-frame) + (maximize-window win) + (when (eq (window-group win) (current-group)) + (xwin-unhide (window-xwin win) (window-parent win))) + ;; We have to restore the focus after hiding. + (when (eq win (screen-focus (window-screen win))) + (screen-set-focus (window-screen win) win)) + (frame-raise-window group to-frame win) + ;; if win was focused in its old frame then give the old + ;; frame the frame's last focused window. + (when (eq (frame-window f) win) + ;; the current value is no longer valid. + (setf (frame-window f) nil) + (frame-raise-window group f (first (frame-windows group f)) nil))))) + +;; In the future, this window will raise the window into the current +;; frame. +(defun focus-forward (group window-list &optional pull-p (predicate (constantly t))) + "Set the focus to the next item in window-list from the focused +window. If PULL-P is T then pull the window into the current +frame." + ;; The window with focus is the "current" window, so find it in the + ;; list and give that window focus + (let* ((w (group-current-window group)) + (wins (remove-if-not predicate (cdr (member w window-list)))) + (nw (if (null wins) + ;; If the last window in the list is focused, then + ;; focus the first one. + (car (remove-if-not predicate window-list)) + ;; Otherwise, focus the next one in the list. + (first wins)))) + ;; there's still the case when the window is the only one in the + ;; list, so make sure its not the same as the current window. + (if (and nw + (not (eq w nw))) + (if pull-p + (pull-window nw) + (frame-raise-window group (window-frame nw) nw)) + (message "No other window.")))) + +;;; Window listing + +(defun echo-windows (group fmt &optional (windows (group-windows group))) + "Print a list of the windows to the screen." + (let* ((wins (sort1 windows '< :key 'window-number)) + (highlight (position (group-current-window group) wins)) + (names (mapcar (lambda (w) + (format-expand *window-formatters* fmt w)) wins))) + (if (null wins) + (echo-string (group-screen group) "No Managed Windows") + (echo-string-list (group-screen group) names highlight)))) + +;;; Window selection + +(defun select-window (group query) + "Read input from the user and go to the selected window." + (let (match) + (labels ((match (win) + (let* ((wname (window-name win)) + (end (min (length wname) (length query)))) + (string-equal wname query :end1 end :end2 end)))) + (unless (null query) + (setf match (find-if #'match (group-windows group)))) + (when match + (frame-raise-window group (window-frame match) match))))) + +(defun select-window-number (group num) + (labels ((match (win) + (= (window-number win) num))) + (let ((win (find-if #'match (group-windows group)))) + (when win + (frame-raise-window group (window-frame win) win))))) + +;;; The Other Window + +(defun other-window (group) + (let* ((wins (group-windows group)) + ;; the frame could be empty + (win (if (group-current-window group) + (second wins) + (first wins)))) + (if win + (frame-raise-window group (window-frame win) win) + (echo-string (group-screen group) "No other window.")))) + +(defun other-window-in-frame (group) + (let* ((f (tile-group-current-frame group)) + (wins (frame-windows group f)) + (win (if (frame-window f) + (second wins) + (first wins)))) + (if win + (frame-raise-window group (window-frame win) win) + (echo-string (group-screen group) "No other window.")))) + +;;; Hidden windows + +(defun other-hidden-window (group) + "Return the last window that was accessed and that is hidden." + (let ((wins (remove-if (lambda (w) (eq (frame-window (window-frame w)) w)) (group-windows group)))) + (first wins))) + +(defun pull-other-hidden-window (group) + "pull the last accessed hidden window from any frame into the +current frame and raise it." + (let ((win (other-hidden-window group))) + (if win + (pull-window win) + (echo-string (group-screen group) "No other window.")))) + +;;; window placement commands + +(defun make-rule-for-window (window &optional lock title) + "Guess at a placement rule for WINDOW and add it to the current set." + (let* ((group (window-group window)) + (group-name (group-name group)) + (frame-number (frame-number (window-frame window))) + (role (window-role window))) + (push (list group-name frame-number t lock + :class (window-class window) + :instance (window-res window) + :title (and title (window-name window)) + :role (and (not (equal role "")) role)) + *window-placement-rules*))) + +(defun dump-window-placement-rules (file) + "Dump *window-placement-rules* to FILE." + (dump-to-file *window-placement-rules* file)) + +(defun restore-window-placement-rules (file) + "Restore *window-placement-rules* from FILE." + (setf *window-placement-rules* (read-dump-from-file file))) + +;;; window.lisp ends here -- 1.5.5.1