1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Info function (see the end of this file for user definition
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2005-2013 Philippe Brochard <pbrochard@common-lisp.net>
10 ;;; This program is free software; you can redistribute it and/or modify
11 ;;; it under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 3 of the License, or
13 ;;; (at your option) any later version.
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with this program; if not, write to the Free Software
22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
24 ;;; --------------------------------------------------------------------------
28 (defstruct info window gc font list ilw ilh x y max-x max-y
)
31 (defparameter *info-selected-item
* nil
)
34 (defun leave-info-mode (info)
36 (declare (ignore info
))
37 (setf *info-selected-item
* nil
)
38 (throw 'exit-info-loop nil
))
40 (defun leave-info-mode-and-valid (info)
41 "Leave the info mode and valid the selected item"
42 (declare (ignore info
))
43 (throw 'exit-info-loop nil
))
45 (defun mouse-leave-info-mode (window root-x root-y info
)
47 (declare (ignore window root-x root-y info
))
48 (setf *info-selected-item
* nil
)
49 (throw 'exit-info-loop nil
))
53 (defun find-info-item-from-mouse (root-x root-y info
)
54 (if (< (x-drawable-x (info-window info
)) root-x
55 (+ (x-drawable-x (info-window info
))
56 (x-drawable-width (info-window info
))))
57 (truncate (/ (- (+ (- root-y
(x-drawable-y (info-window info
)))
58 (xlib:max-char-ascent
(info-font info
))
59 (info-y info
)) (info-ilh info
)) (info-ilh info
)))
63 (defun set-info-item-form-mouse (root-x root-y info
)
64 (setf *info-selected-item
* (find-info-item-from-mouse root-x root-y info
)))
67 (defun info-y-display-coords (info posy
)
68 (- (+ (* (info-ilh info
) posy
) (info-ilh info
)) (info-y info
)))
70 (defun incf-info-selected-item (info n
)
71 (setf *info-selected-item
*
72 (min (if *info-selected-item
*
73 (+ *info-selected-item
* n
)
75 (1- (or (length (info-list info
)) 1)))))
77 (defun decf-info-selected-item (info n
)
78 (declare (ignore info
))
79 (setf *info-selected-item
*
80 (max (if *info-selected-item
*
81 (- *info-selected-item
* n
)
87 (defun draw-info-window (info)
88 (labels ((print-line (line posx posy
&optional
(color *info-foreground
*))
89 (xlib:with-gcontext
((info-gc info
) :foreground
(get-color color
)
90 :background
(if (equal posy
*info-selected-item
*)
91 (get-color *info-selected-background
*)
92 (get-color *info-background
*)))
93 (funcall (if (equal posy
*info-selected-item
*)
94 #'xlib
:draw-image-glyphs
96 *pixmap-buffer
* (info-gc info
)
97 (- (+ (info-ilw info
) (* posx
(info-ilw info
))) (info-x info
))
98 (info-y-display-coords info posy
)
99 (format nil
"~A" line
)))
100 (+ posx
(length line
))))
101 (clear-pixmap-buffer (info-window info
) (info-gc info
))
102 (loop for line in
(info-list info
)
105 (cons (typecase (first line
)
106 (cons (let ((posx 0))
109 (cons (setf posx
(print-line (first l
) posx y
(second l
))))
110 (t (setf posx
(print-line l posx y
)))))))
111 (t (print-line (first line
) 0 y
(second line
)))))
112 (t (print-line line
0 y
))))
113 (copy-pixmap-buffer (info-window info
) (info-gc info
))))
123 (add-hook *binding-hook
* 'init-
*info-keys
* 'init-
*info-mouse
*)
125 (defun set-default-info-keys ()
126 (define-info-key (#\q
) 'leave-info-mode
)
127 (define-info-key ("Return") 'leave-info-mode-and-valid
)
128 (define-info-key ("KP_Enter" :mod-2
) 'leave-info-mode-and-valid
)
129 (define-info-key ("space") 'leave-info-mode-and-valid
)
130 (define-info-key ("Escape") 'leave-info-mode
)
131 (define-info-key ("g" :control
) 'leave-info-mode
)
132 (define-info-key ("twosuperior")
133 (defun info-banish-pointer (info)
134 "Move the pointer to the lower right corner of the screen"
135 (declare (ignore info
))
137 (define-info-key ("Down")
138 (defun info-next-line (info)
140 (incf-info-selected-item info
1)
141 (when (> (info-y-display-coords info
*info-selected-item
*)
142 (+ (x-drawable-y (info-window info
))
143 (x-drawable-height (info-window info
))))
144 (setf (info-y info
) (min (+ (info-y info
) (info-ilh info
)) (info-max-y info
))))
145 (draw-info-window info
)))
146 (define-info-key ("Up")
147 (defun info-previous-line (info)
149 (decf-info-selected-item info
1)
150 (when (< (info-y-display-coords info
*info-selected-item
*)
151 (+ (x-drawable-y (info-window info
))
153 (setf (info-y info
) (max (- (info-y info
) (info-ilh info
)) 0)))
154 (draw-info-window info
)))
155 (define-info-key ("Left")
156 (defun info-previous-char (info)
158 (setf (info-x info
) (max (- (info-x info
) (info-ilw info
)) 0))
159 (draw-info-window info
)))
160 (define-info-key ("Right")
161 (defun info-next-char (info)
162 "Move one char right"
163 (setf (info-x info
) (min (+ (info-x info
) (info-ilw info
)) (info-max-x info
)))
164 (draw-info-window info
)))
165 (define-info-key ("Home")
166 (defun info-first-line (info)
168 (setf (info-x info
) 0
170 (setf *info-selected-item
* 0)
171 (draw-info-window info
)))
172 (define-info-key ("End")
173 (defun info-end-line (info)
175 (setf (info-x info
) 0
176 (info-y info
) (- (* (length (info-list info
)) (info-ilh info
)) (x-drawable-height (info-window info
))))
177 (setf *info-selected-item
* (1- (or (length (info-list info
)) 1)))
178 (draw-info-window info
)))
179 (define-info-key ("Page_Down")
180 (defun info-next-ten-lines (info)
181 "Move ten lines down"
182 (incf-info-selected-item info
10)
183 (when (> (info-y-display-coords info
*info-selected-item
*)
184 (+ (x-drawable-y (info-window info
))
185 (x-drawable-height (info-window info
))))
186 (setf (info-y info
) (min (+ (info-y info
) (* (info-ilh info
) 10)) (info-max-y info
))))
187 (draw-info-window info
)))
188 (define-info-key ("Page_Up")
189 (defun info-previous-ten-lines (info)
191 (decf-info-selected-item info
10)
192 (when (< (info-y-display-coords info
*info-selected-item
*)
193 (+ (x-drawable-y (info-window info
))
195 (setf (info-y info
) (max (- (info-y info
) (* (info-ilh info
) 10)) 0)))
196 (draw-info-window info
))))
198 (add-hook *binding-hook
* 'set-default-info-keys
)
203 (defparameter *info-start-grab-x
* nil
)
204 (defparameter *info-start-grab-y
* nil
)
207 (defun info-begin-grab (window root-x root-y info
)
209 (declare (ignore window
))
210 (setf *info-start-grab-x
* (min (max (+ root-x
(info-x info
)) 0) (info-max-x info
))
211 *info-start-grab-y
* (min (max (+ root-y
(info-y info
)) 0) (info-max-y info
)))
212 (draw-info-window info
))
214 (defun info-end-grab (window root-x root-y info
)
216 (declare (ignore window
))
217 (setf (info-x info
) (min (max (- *info-start-grab-x
* root-x
) 0) (info-max-x info
))
218 (info-y info
) (min (max (- *info-start-grab-y
* root-y
) 0) (info-max-y info
))
219 *info-start-grab-x
* nil
220 *info-start-grab-y
* nil
)
221 (draw-info-window info
))
223 (defun info-mouse-next-line (window root-x root-y info
)
225 (declare (ignore window
))
226 (setf (info-y info
) (min (+ (info-y info
) (info-ilh info
)) (info-max-y info
)))
227 (set-info-item-form-mouse root-x root-y info
)
228 (draw-info-window info
))
230 (defun info-mouse-previous-line (window root-x root-y info
)
232 (declare (ignore window
))
233 (setf (info-y info
) (max (- (info-y info
) (info-ilh info
)) 0))
234 (set-info-item-form-mouse root-x root-y info
)
235 (draw-info-window info
))
238 (defun info-mouse-motion-drag (window root-x root-y info
)
240 (declare (ignore window
))
241 (when (and *info-start-grab-x
* *info-start-grab-y
*)
242 (setf (info-x info
) (min (max (- *info-start-grab-x
* root-x
) 0) (info-max-x info
))
243 (info-y info
) (min (max (- *info-start-grab-y
* root-y
) 0) (info-max-y info
)))
244 (draw-info-window info
)))
252 (defun info-mouse-select-item (window root-x root-y info
)
253 (declare (ignore window
))
254 (set-info-item-form-mouse root-x root-y info
)
255 (leave-info-mode-and-valid info
))
257 (defun info-mouse-motion-click (window root-x root-y info
)
258 (declare (ignore window
))
259 (let ((last *info-selected-item
*))
260 (set-info-item-form-mouse root-x root-y info
)
261 (unless (equal last
*info-selected-item
*)
262 (draw-info-window info
))))
266 (defun set-default-info-mouse ()
267 (if *info-click-to-select
*
268 (define-info-mouse (1) nil
'info-mouse-select-item
)
269 (define-info-mouse (1) 'info-begin-grab
'info-end-grab
))
270 (define-info-mouse (2) 'mouse-leave-info-mode
)
271 (define-info-mouse (3) 'mouse-leave-info-mode
)
272 (define-info-mouse (4) 'info-mouse-previous-line
)
273 (define-info-mouse (5) 'info-mouse-next-line
)
274 (if *info-click-to-select
*
275 (define-info-mouse ('motion
) 'info-mouse-motion-click nil
)
276 (define-info-mouse ('motion
) 'info-mouse-motion-drag nil
)))
278 (add-hook *binding-hook
* 'set-default-info-mouse
)
283 (define-handler info-mode
:key-press
(code state
)
284 (funcall-key-from-code *info-keys
* code state info
))
286 (define-handler info-mode
:motion-notify
(window root-x root-y
)
287 (unless (compress-motion-notify)
288 (funcall-button-from-code *info-mouse
* 'motion
(modifiers->state
*default-modifiers
*)
289 window root-x root-y
*fun-press
* (list info
))))
291 (define-handler info-mode
:button-press
(window root-x root-y code state
)
292 (funcall-button-from-code *info-mouse
* code state window root-x root-y
*fun-press
* (list info
)))
294 (define-handler info-mode
:button-release
(window root-x root-y code state
)
295 (funcall-button-from-code *info-mouse
* code state window root-x root-y
*fun-release
* (list info
)))
299 (defun info-mode (info-list &key
(width nil
) (height nil
))
300 "Open the info mode. Info-list is a list of info: One string per line
301 Or for colored output: a list (line_string color)
302 Or ((1_word color) (2_word color) 3_word (4_word color)...)"
304 (setf *info-selected-item
* 0)
305 (labels ((compute-size (line)
307 (cons (typecase (first line
)
310 (incf val
(typecase l
311 (cons (length (first l
)))
313 (t (length (first line
)))))
315 (let* ((font (xlib:open-font
*display
* *info-font-string
*))
316 (ilw (xlib:max-char-width font
))
317 (ilh (+ (xlib:max-char-ascent font
) (xlib:max-char-descent font
) 1))
319 (min (* (+ (loop for l in info-list maximize
(compute-size l
)) 2) ilw
)
320 (xlib:screen-width
*screen
*))))
322 (min (round (+ (* (length info-list
) ilh
) (/ ilh
2)))
323 (xlib:screen-height
*screen
*)))))
324 (with-placement (*info-mode-placement
* x y width height
)
325 (let* ((window (xlib:create-window
:parent
*root
*
329 :background
(get-color *info-background
*)
330 :colormap
(xlib:screen-default-colormap
*screen
*)
331 :border-width
*border-size
*
332 :border
(get-color *info-border
*)
333 :event-mask
'(:exposure
)))
334 (gc (xlib:create-gcontext
:drawable window
335 :foreground
(get-color *info-foreground
*)
336 :background
(get-color *info-background
*)
338 :line-style
:solid
)))
339 (setf info
(make-info :window window
:gc gc
:x
0 :y
0 :list info-list
340 :font font
:ilw ilw
:ilh ilh
341 :max-x
(* (loop for l in info-list maximize
(compute-size l
)) ilw
)
342 :max-y
(* (length info-list
) ilh
)))
343 (setf (window-transparency window
) *info-transparency
*)
345 (draw-info-window info
)
346 (wait-no-key-or-button-press)
347 (with-grab-keyboard-and-pointer (68 69 66 67)
348 (generic-mode 'info-mode
'exit-info-loop
349 :loop-function
(lambda ()
350 (raise-window (info-window info
)))
351 :original-mode
'(main-mode)))
352 (xlib:free-gcontext gc
)
353 (xlib:destroy-window window
)
354 (xlib:close-font font
)
355 (xlib:display-finish-output
*display
*)
356 (display-all-frame-info)
357 (wait-no-key-or-button-press)
358 *info-selected-item
*)))))))
362 (defun info-mode-menu (item-list &key
(width nil
) (height nil
))
363 "Open an info help menu.
364 Item-list is: '((key function) separator (key function))
365 or with explicit docstring: '((key function \"documentation 1\") (key function \"bla bla\") (key function))
366 key is a character, a keycode or a keysym
367 Separator is a string or a symbol (all but a list)
368 Function can be a function or a list (function color) for colored output"
369 (let ((info-list nil
)
371 (old-info-keys (copy-hash-table *info-keys
*)))
372 (labels ((define-key (key function
)
373 (define-info-key-fun (list key
)
374 (lambda (&optional args
)
375 (declare (ignore args
))
376 (setf action function
)
377 (leave-info-mode nil
)))))
378 (dolist (item item-list
)
380 (cons (destructuring-bind (key function explicit-doc
) (ensure-n-elems item
3)
382 (cons (push (list (list (format nil
"~A" key
) *menu-color-menu-key
*)
383 (list (format nil
": ~A" (or explicit-doc
(documentation (first function
) 'function
)))
386 (define-key key
(first function
)))
387 (t (push (list (list (format nil
"~A" key
) *menu-color-key
*)
388 (format nil
": ~A" (or explicit-doc
(documentation function
'function
))))
390 (define-key key function
)))))
391 (t (push (list (format nil
"-=- ~A -=-" item
) *menu-color-comment
*) info-list
))))
392 (let ((selected-item (info-mode (nreverse info-list
) :width width
:height height
)))
393 (setf *info-keys
* old-info-keys
)
395 (awhen (nth selected-item item-list
)
397 (destructuring-bind (key function explicit-doc
) (ensure-n-elems it
3)
398 (declare (ignore key explicit-doc
))
400 (cons (setf action
(first function
)))
401 (t (setf action function
)))))))
403 (function (funcall action
))
404 (symbol (when (fboundp action
)
405 (funcall action
))))))))
411 (defun keys-from-list (list)
412 "Produce a key menu based on list item"
415 collect
(list (number->char i
) l
)))
419 ;;;| CONFIG - Info mode functions
421 (defun key-binding-colorize-line (list)
422 (loop :for line
:in list
423 :collect
(cond ((search "* CLFSWM Keys *" line
) (list line
*info-color-title
*))
424 ((search "---" line
) (list line
*info-color-underline
*))
425 ((begin-with-2-spaces line
)
426 (list (list (subseq line
0 22) *info-color-second
*)
427 (list (subseq line
22 35) *info-color-first
*)
432 (defun show-key-binding (&rest hash-table-key
)
433 "Show the binding of each hash-table-key.
434 Pass the :no-producing-doc symbol to remove the producing doc"
435 (info-mode (key-binding-colorize-line
436 (split-string (append-newline-space
437 (with-output-to-string (stream)
438 (produce-doc (remove :no-producing-doc hash-table-key
)
440 (not (member :no-producing-doc hash-table-key
)))))
444 (defun show-global-key-binding ()
445 "Show all key binding"
446 (show-key-binding *main-keys
* *main-mouse
* *second-keys
* *second-mouse
*
447 *info-keys
* *info-mouse
*))
449 (defun show-main-mode-key-binding ()
450 "Show the main mode binding"
451 (show-key-binding *main-keys
* *main-mouse
*))
453 (defun show-second-mode-key-binding ()
454 "Show the second mode key binding"
455 (show-key-binding *second-keys
* *second-mouse
*))
457 (defun show-circulate-mode-key-binding ()
458 "Show the circulate mode key binding"
459 (show-key-binding *circulate-keys
*))
461 (defun show-expose-window-mode-key-binding ()
462 "Show the expose window mode key binding"
463 (show-key-binding *expose-keys
* *expose-mouse
*))
466 (defun show-first-aid-kit ()
467 "Show the first aid kit key binding"
468 (labels ((add-key (hash symbol
&optional
(hashkey *main-keys
*))
469 (multiple-value-bind (k v
)
470 (find-in-hash symbol hashkey
)
471 (setf (gethash k hash
) v
))))
472 (let ((hash (make-hash-table :test
#'equal
))
473 (hash-second (make-hash-table :test
#'equal
)))
474 (setf (gethash 'name hash
) "First aid kit - Main mode key binding"
475 (gethash 'name hash-second
) "First aid kit - Second mode key binding")
476 (add-key hash
'select-next-child
)
477 (add-key hash
'select-previous-child
)
478 (add-key hash
'select-next-brother
)
479 (add-key hash
'select-previous-brother
)
480 (add-key hash
'select-previous-level
)
481 (add-key hash
'select-next-level
)
482 (add-key hash
'enter-frame
)
483 (add-key hash
'leave-frame
)
484 (add-key hash
'second-key-mode
)
485 (add-key hash
'expose-windows-mode
)
486 (add-key hash
'expose-all-windows-mode
)
487 (add-key hash
'present-clfswm-terminal
)
488 (add-key hash-second
'leave-second-mode
*second-keys
*)
489 (add-key hash-second
'open-menu
*second-keys
*)
490 (add-key hash-second
'run-program-from-query-string
*second-keys
*)
491 (add-key hash-second
'eval-from-query-string
*second-keys
*)
492 (add-key hash-second
'set-open-in-new-frame-in-parent-frame-nw-hook
*second-keys
*)
493 (add-key hash-second
'b-start-xterm
*second-keys
*)
494 (add-key hash-second
'b-start-emacs
*second-keys
*)
495 (show-key-binding hash hash-second
:no-producing-doc
))))
498 (defun corner-help-colorize-line (list)
499 (loop :for line
:in list
500 :collect
(cond ((search "CLFSWM:" line
) (list line
*info-color-title
*))
501 ((search "*:" line
) (list line
*info-color-underline
*))
502 ((begin-with-2-spaces line
)
503 (let ((pos (position #\
: line
)))
505 (list (list (subseq line
0 (1+ pos
)) *info-color-first
*)
506 (subseq line
(1+ pos
)))
510 (defun show-corner-help ()
511 "Help on clfswm corner"
512 (info-mode (corner-help-colorize-line
513 (split-string (append-newline-space
514 (with-output-to-string (stream)
515 (produce-corner-doc stream
)))
519 (defun configuration-variable-colorize-line (list)
520 (loop :for line
:in list
521 :collect
(cond ((search "CLFSWM " line
) (list line
*info-color-title
*))
523 (let ((pos (position #\
= line
)))
524 (list (list (subseq line
0 (1+ pos
)) *info-color-first
*)
525 (list (subseq line
(1+ pos
)) *info-color-second
*))))
526 ((search "<=" line
) (list line
*info-color-underline
*))
530 (defun show-config-variable ()
531 "Show all configurable variables"
535 (info-mode-menu (loop :for group
:in
(config-all-groups)
537 :collect
(list (number->char i
)
540 (setf result group
)))
541 (config-group->string group
))))
543 (info-mode (configuration-variable-colorize-line
544 (split-string (append-newline-space
545 (with-output-to-string (stream)
546 (produce-conf-var-doc stream result t nil
)))
555 "Show the current time and date"
556 (info-mode (list (list `("Current date:" ,*menu-color-comment
*) (date-string)))))
563 (defun info-on-shell (msg program
)
564 (let ((lines (do-shell program nil t
)))
565 (info-mode (append (list (list msg
*menu-color-comment
*))
566 (loop for line
= (read-line lines nil nil
)
568 collect
(ensure-printable line
))))))
572 (defun show-cpu-proc ()
573 "Show current processes sorted by CPU usage"
574 (info-on-shell "Current processes sorted by CPU usage:"
575 "ps --cols=1000 --sort='-%cpu,uid,pgid,ppid,pid' -e -o user,pid,stime,pcpu,pmem,args"))
577 (defun show-mem-proc ()
578 "Show current processes sorted by memory usage"
579 (info-on-shell "Current processes sorted by MEMORY usage:"
580 "ps --cols=1000 --sort='-vsz,uid,pgid,ppid,pid' -e -o user,pid,stime,pcpu,pmem,args"))
583 (defun show-cd-info ()
584 "Show the current CD track"
585 (info-on-shell "Current CD track:" "pcd i"))
587 (defun show-cd-playlist ()
588 "Show the current CD playlist"
589 (info-on-shell "Current CD playlist:" "pcd mi"))
592 (defun show-version ()
593 "Show the current CLFSWM version"
594 (info-mode (list *version
*)))