Find file
Fetching contributors…
Cannot retrieve contributors at this time
270 lines (238 sloc) 11.8 KB
;; Copyright (C) 2003-2008 Shawn Betts
;; 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
;; 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:
;; message printing functions
;; Code:
(in-package #:stumpwm)
(export '(echo-string
(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
((:top-right :bottom-right :right) (- maxx width))
((:top :bottom :center) (truncate (- maxx minx width) 2))
(t minx))
(case gravity
((:bottom-left :bottom-right :bottom) (- maxy height))
((:left :right :center) (truncate (- maxy miny height) 2))
(t miny))))
(defun setup-win-gravity (screen win gravity)
"Position the x, y of the window according to its gravity. This
function expects to be wrapped in a with-state for win."
(xlib:with-state ((screen-root screen))
(let ((w (xlib:drawable-width win))
(h (xlib:drawable-height win))
(screen-width (head-width (current-head)))
(screen-height (head-height (current-head))))
(let ((x (case gravity
((:top-left :bottom-left) 0)
(:center (truncate (- screen-width w (* (xlib:drawable-border-width win) 2)) 2))
(t (- screen-width w (* (xlib:drawable-border-width win) 2)))))
(y (case gravity
((:bottom-right :bottom-left) (- screen-height h (* (xlib:drawable-border-width win) 2)))
(:center (truncate (- screen-height h (* (xlib:drawable-border-width win) 2)) 2))
(t 0))))
(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)
(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)))
(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)
(xlib:unmap-window (screen-frame-window screen)))
(defun unmap-all-frame-indicator-windows ()
(mapc #'unmap-frame-indicator-window *screen-list*)
(when (timer-p *frame-indicator-timer*)
(cancel-timer *frame-indicator-timer*)
(setf *frame-indicator-timer* nil)))
(defun reset-message-window-timer ()
"Set the message window timer to timeout in *timeout-wait* seconds."
(unless *ignore-echo-timeout*
(when (timer-p *message-window-timer*)
(cancel-timer *message-window-timer*))
(setf *message-window-timer* (run-with-timer *timeout-wait* nil
(defun reset-frame-indicator-timer ()
"Set the message window timer to timeout in *timeout-wait* seconds."
(when (timer-p *frame-indicator-timer*)
(cancel-timer *frame-indicator-timer*))
(setf *frame-indicator-timer* (run-with-timer *timeout-frame-indicator-wait* nil
(defun show-frame-outline (group &optional (clear t))
;; Don't draw if this isn't a current group!
(when (find group (mapcar 'screen-current-group *screen-list*))
(dformat 5 "show-frame-outline!~%")
;; *resize-hides-windows* uses the frame outlines for display,
;; so try not to interfere.
(unless (eq *top-map* *resize-map*)
(when clear
(clear-frame-outlines group))
(let ((frame (tile-group-current-frame group)))
(unless (and (= 1 (length (tile-group-frame-tree group)))
(atom (first (tile-group-frame-tree group))))
;; draw the outline
(unless (frame-window frame)
(draw-frame-outline group frame t t)))))))
(defun show-frame-indicator (group &optional force)
(show-frame-outline group)
;; FIXME: Arg, these tests are already done in show-frame-outline
(when (find group (mapcar 'screen-current-group *screen-list*))
(when (or force
(and (or (> (length (tile-group-frame-tree group)) 1)
(not (atom (first (tile-group-frame-tree group)))))
(not *suppress-frame-indicator*)))
(let ((frame (tile-group-current-frame group))
(w (screen-frame-window (current-screen)))
(string (if (stringp *frame-indicator-text*)
(prin1-to-string *frame-indicator-text*)))
(font (screen-font (current-screen))))
;; If it's already mapped it'll appear briefly in the wrong
;; place, so unmap it first.
(xlib:unmap-window w)
(xlib:with-state (w)
(setf (xlib:drawable-x w) (+ (frame-x frame)
(truncate (- (frame-width frame) (xlib:text-width font string)) 2))
(xlib:drawable-y w) (+ (frame-display-y group frame)
(truncate (- (frame-height frame) (font-height font)) 2))
(xlib:window-priority w) :above))
(xlib:map-window w)
(echo-in-window w font (screen-fg-color (current-screen)) (screen-bg-color (current-screen)) 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 :translate #'translate-id :size 16)))
(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."
(when strings
(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)
(screen-current-msg-highlights screen)
(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))
(dformat 5 "Outputting a message:~%~{ ~a~%~}" strings)
(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)
(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)))
;;; Commands
(defvar *lastmsg-nth* nil)
(defcommand lastmsg () ()
"Display the last message. If the previous command was lastmsg, then
continue cycling back through the message history."
(if (string= *last-command* "lastmsg")
(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.")))