1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Info function (see the end of this file for user definition
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2005-2015 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 (ensure-printable (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
)
322 (min (round (+ (* (length info-list
) ilh
) (/ ilh
2)))
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 :original-mode
'(main-mode)))
350 (xlib:free-gcontext gc
)
351 (xlib:destroy-window window
)
352 (xlib:close-font font
)
353 (xlib:display-finish-output
*display
*)
354 (display-all-frame-info)
355 (wait-no-key-or-button-press)
356 *info-selected-item
*)))))))
360 (defun info-mode-menu (item-list &key
(width nil
) (height nil
))
361 "Open an info help menu.
362 Item-list is: '((key function) separator (key function))
363 or with explicit docstring: '((key function \"documentation 1\") (key function \"bla bla\") (key function))
364 key is a character, a keycode or a keysym
365 Separator is a string or a symbol (all but a list)
366 Function can be a function or a list (function color) for colored output"
367 (let ((info-list nil
)
369 (old-info-keys (copy-hash-table *info-keys
*)))
370 (labels ((define-key (key function
)
371 (define-info-key-fun (list key
)
372 (lambda (&optional args
)
373 (declare (ignore args
))
374 (setf action function
)
375 (leave-info-mode nil
)))))
376 (dolist (item item-list
)
378 (cons (destructuring-bind (key function explicit-doc
) (ensure-n-elems item
3)
380 (cons (push (list (list (format nil
"~A" key
) *menu-color-menu-key
*)
381 (list (format nil
": ~A" (or explicit-doc
(documentation (first function
) 'function
)))
384 (define-key key
(first function
)))
385 (t (push (list (list (format nil
"~A" key
) *menu-color-key
*)
386 (format nil
": ~A" (or explicit-doc
(documentation function
'function
))))
388 (define-key key function
)))))
389 (t (push (list (format nil
"-=- ~A -=-" item
) *menu-color-comment
*) info-list
))))
390 (let ((selected-item (info-mode (nreverse info-list
) :width width
:height height
)))
391 (setf *info-keys
* old-info-keys
)
393 (awhen (nth selected-item item-list
)
395 (destructuring-bind (key function explicit-doc
) (ensure-n-elems it
3)
396 (declare (ignore key explicit-doc
))
398 (cons (setf action
(first function
)))
399 (t (setf action function
)))))))
401 (function (funcall action
))
402 (symbol (when (fboundp action
)
403 (funcall action
))))))))
409 (defun keys-from-list (list)
410 "Produce a key menu based on list item"
413 collect
(list (number->char i
) l
)))
417 ;;;| CONFIG - Info mode functions
419 (defun key-binding-colorize-line (list)
420 (loop :for line
:in list
421 :collect
(cond ((search "* CLFSWM Keys *" line
) (list line
*info-color-title
*))
422 ((search "---" line
) (list line
*info-color-underline
*))
423 ((begin-with-2-spaces line
)
424 (list (list (subseq line
0 22) *info-color-second
*)
425 (list (subseq line
22 35) *info-color-first
*)
430 (defun show-key-binding (&rest hash-table-key
)
431 "Show the binding of each hash-table-key.
432 Pass the :no-producing-doc symbol to remove the producing doc"
433 (info-mode (key-binding-colorize-line
434 (split-string (append-newline-space
435 (with-output-to-string (stream)
436 (produce-doc (remove :no-producing-doc hash-table-key
)
438 (not (member :no-producing-doc hash-table-key
)))))
442 (defun show-global-key-binding ()
443 "Show all key binding"
444 (show-key-binding *main-keys
* *main-mouse
* *second-keys
* *second-mouse
*
445 *info-keys
* *info-mouse
*))
447 (defun show-main-mode-key-binding ()
448 "Show the main mode binding"
449 (show-key-binding *main-keys
* *main-mouse
*))
451 (defun show-second-mode-key-binding ()
452 "Show the second mode key binding"
453 (show-key-binding *second-keys
* *second-mouse
*))
455 (defun show-circulate-mode-key-binding ()
456 "Show the circulate mode key binding"
457 (show-key-binding *circulate-keys
*))
459 (defun show-expose-window-mode-key-binding ()
460 "Show the expose window mode key binding"
461 (show-key-binding *expose-keys
* *expose-mouse
*))
464 (defun show-first-aid-kit ()
465 "Show the first aid kit key binding"
466 (labels ((add-key (hash symbol
&optional
(hashkey *main-keys
*))
467 (multiple-value-bind (k v
)
468 (find-in-hash symbol hashkey
)
469 (setf (gethash k hash
) v
))))
470 (let ((hash (make-hash-table :test
#'equal
))
471 (hash-second (make-hash-table :test
#'equal
)))
472 (setf (gethash 'name hash
) "First aid kit - Main mode key binding"
473 (gethash 'name hash-second
) "First aid kit - Second mode key binding")
474 (add-key hash
'select-next-child
)
475 (add-key hash
'select-previous-child
)
476 (add-key hash
'select-next-brother
)
477 (add-key hash
'select-previous-brother
)
478 (add-key hash
'select-previous-level
)
479 (add-key hash
'select-next-level
)
480 (add-key hash
'enter-frame
)
481 (add-key hash
'leave-frame
)
482 (add-key hash
'second-key-mode
)
483 (add-key hash
'expose-windows-mode
)
484 (add-key hash
'expose-all-windows-mode
)
485 (add-key hash
'present-clfswm-terminal
)
486 (add-key hash-second
'leave-second-mode
*second-keys
*)
487 (add-key hash-second
'open-menu
*second-keys
*)
488 (add-key hash-second
'run-program-from-query-string
*second-keys
*)
489 (add-key hash-second
'eval-from-query-string
*second-keys
*)
490 (add-key hash-second
'set-open-in-new-frame-in-parent-frame-nw-hook
*second-keys
*)
491 (add-key hash-second
'b-start-xterm
*second-keys
*)
492 (add-key hash-second
'b-start-emacs
*second-keys
*)
493 (show-key-binding hash hash-second
:no-producing-doc
))))
496 (defun corner-help-colorize-line (list)
497 (loop :for line
:in list
498 :collect
(cond ((search "CLFSWM:" line
) (list line
*info-color-title
*))
499 ((search "*:" line
) (list line
*info-color-underline
*))
500 ((begin-with-2-spaces line
)
501 (let ((pos (position #\
: line
)))
503 (list (list (subseq line
0 (1+ pos
)) *info-color-first
*)
504 (subseq line
(1+ pos
)))
508 (defun show-corner-help ()
509 "Help on clfswm corner"
510 (info-mode (corner-help-colorize-line
511 (split-string (append-newline-space
512 (with-output-to-string (stream)
513 (produce-corner-doc stream
)))
517 (defun configuration-variable-colorize-line (list)
518 (loop :for line
:in list
519 :collect
(cond ((search "CLFSWM " line
) (list line
*info-color-title
*))
521 (let ((pos (position #\
= line
)))
522 (list (list (subseq line
0 (1+ pos
)) *info-color-first
*)
523 (list (subseq line
(1+ pos
)) *info-color-second
*))))
524 ((search "<=" line
) (list line
*info-color-underline
*))
528 (defun show-config-variable ()
529 "Show all configurable variables"
533 (info-mode-menu (loop :for group
:in
(config-all-groups)
535 :collect
(list (number->char i
)
538 (setf result group
)))
539 (config-group->string group
))))
541 (info-mode (configuration-variable-colorize-line
542 (split-string (append-newline-space
543 (with-output-to-string (stream)
544 (produce-conf-var-doc stream result t nil
)))
553 "Show the current time and date"
554 (info-mode (list (list `("Current date:" ,*menu-color-comment
*) (date-string)))))
561 (defun info-on-shell (msg program
)
562 (let ((lines (do-shell program nil t
)))
563 (info-mode (append (list (list msg
*menu-color-comment
*))
564 (loop for line
= (read-line lines nil nil
)
566 collect
(ensure-printable line
))))))
570 (defun show-cpu-proc ()
571 "Show current processes sorted by CPU usage"
572 (info-on-shell "Current processes sorted by CPU usage:"
573 "ps --cols=1000 --sort='-%cpu,uid,pgid,ppid,pid' -e -o user,pid,stime,pcpu,pmem,args"))
575 (defun show-mem-proc ()
576 "Show current processes sorted by memory usage"
577 (info-on-shell "Current processes sorted by MEMORY usage:"
578 "ps --cols=1000 --sort='-vsz,uid,pgid,ppid,pid' -e -o user,pid,stime,pcpu,pmem,args"))
581 (defun show-cd-info ()
582 "Show the current CD track"
583 (info-on-shell "Current CD track:" "pcd i"))
585 (defun show-cd-playlist ()
586 "Show the current CD playlist"
587 (info-on-shell "Current CD playlist:" "pcd mi"))
590 (defun show-version ()
591 "Show the current CLFSWM version"
592 (info-mode (list *version
*)))