1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Info function (see the end of this file for user definition
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2012 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 ("space") 'leave-info-mode-and-valid
)
129 (define-info-key ("Escape") 'leave-info-mode
)
130 (define-info-key ("g" :control
) 'leave-info-mode
)
131 (define-info-key ("twosuperior")
132 (defun info-banish-pointer (info)
133 "Move the pointer to the lower right corner of the screen"
134 (declare (ignore info
))
136 (define-info-key ("Down")
137 (defun info-next-line (info)
139 (incf-info-selected-item info
1)
140 (when (> (info-y-display-coords info
*info-selected-item
*)
141 (+ (x-drawable-y (info-window info
))
142 (x-drawable-height (info-window info
))))
143 (setf (info-y info
) (min (+ (info-y info
) (info-ilh info
)) (info-max-y info
))))
144 (draw-info-window info
)))
145 (define-info-key ("Up")
146 (defun info-previous-line (info)
148 (decf-info-selected-item info
1)
149 (when (< (info-y-display-coords info
*info-selected-item
*)
150 (+ (x-drawable-y (info-window info
))
152 (setf (info-y info
) (max (- (info-y info
) (info-ilh info
)) 0)))
153 (draw-info-window info
)))
154 (define-info-key ("Left")
155 (defun info-previous-char (info)
157 (setf (info-x info
) (max (- (info-x info
) (info-ilw info
)) 0))
158 (draw-info-window info
)))
159 (define-info-key ("Right")
160 (defun info-next-char (info)
161 "Move one char right"
162 (setf (info-x info
) (min (+ (info-x info
) (info-ilw info
)) (info-max-x info
)))
163 (draw-info-window info
)))
164 (define-info-key ("Home")
165 (defun info-first-line (info)
167 (setf (info-x info
) 0
169 (setf *info-selected-item
* 0)
170 (draw-info-window info
)))
171 (define-info-key ("End")
172 (defun info-end-line (info)
174 (setf (info-x info
) 0
175 (info-y info
) (- (* (length (info-list info
)) (info-ilh info
)) (x-drawable-height (info-window info
))))
176 (setf *info-selected-item
* (1- (or (length (info-list info
)) 1)))
177 (draw-info-window info
)))
178 (define-info-key ("Page_Down")
179 (defun info-next-ten-lines (info)
180 "Move ten lines down"
181 (incf-info-selected-item info
10)
182 (when (> (info-y-display-coords info
*info-selected-item
*)
183 (+ (x-drawable-y (info-window info
))
184 (x-drawable-height (info-window info
))))
185 (setf (info-y info
) (min (+ (info-y info
) (* (info-ilh info
) 10)) (info-max-y info
))))
186 (draw-info-window info
)))
187 (define-info-key ("Page_Up")
188 (defun info-previous-ten-lines (info)
190 (decf-info-selected-item info
10)
191 (when (< (info-y-display-coords info
*info-selected-item
*)
192 (+ (x-drawable-y (info-window info
))
194 (setf (info-y info
) (max (- (info-y info
) (* (info-ilh info
) 10)) 0)))
195 (draw-info-window info
))))
197 (add-hook *binding-hook
* 'set-default-info-keys
)
202 (defparameter *info-start-grab-x
* nil
)
203 (defparameter *info-start-grab-y
* nil
)
206 (defun info-begin-grab (window root-x root-y info
)
208 (declare (ignore window
))
209 (setf *info-start-grab-x
* (min (max (+ root-x
(info-x info
)) 0) (info-max-x info
))
210 *info-start-grab-y
* (min (max (+ root-y
(info-y info
)) 0) (info-max-y info
)))
211 (draw-info-window info
))
213 (defun info-end-grab (window root-x root-y info
)
215 (declare (ignore window
))
216 (setf (info-x info
) (min (max (- *info-start-grab-x
* root-x
) 0) (info-max-x info
))
217 (info-y info
) (min (max (- *info-start-grab-y
* root-y
) 0) (info-max-y info
))
218 *info-start-grab-x
* nil
219 *info-start-grab-y
* nil
)
220 (draw-info-window info
))
222 (defun info-mouse-next-line (window root-x root-y info
)
224 (declare (ignore window
))
225 (setf (info-y info
) (min (+ (info-y info
) (info-ilh info
)) (info-max-y info
)))
226 (set-info-item-form-mouse root-x root-y info
)
227 (draw-info-window info
))
229 (defun info-mouse-previous-line (window root-x root-y info
)
231 (declare (ignore window
))
232 (setf (info-y info
) (max (- (info-y info
) (info-ilh info
)) 0))
233 (set-info-item-form-mouse root-x root-y info
)
234 (draw-info-window info
))
237 (defun info-mouse-motion-drag (window root-x root-y info
)
239 (declare (ignore window
))
240 (when (and *info-start-grab-x
* *info-start-grab-y
*)
241 (setf (info-x info
) (min (max (- *info-start-grab-x
* root-x
) 0) (info-max-x info
))
242 (info-y info
) (min (max (- *info-start-grab-y
* root-y
) 0) (info-max-y info
)))
243 (draw-info-window info
)))
251 (defun info-mouse-select-item (window root-x root-y info
)
252 (declare (ignore window
))
253 (set-info-item-form-mouse root-x root-y info
)
254 (leave-info-mode-and-valid info
))
256 (defun info-mouse-motion-click (window root-x root-y info
)
257 (declare (ignore window
))
258 (let ((last *info-selected-item
*))
259 (set-info-item-form-mouse root-x root-y info
)
260 (unless (equal last
*info-selected-item
*)
261 (draw-info-window info
))))
265 (defun set-default-info-mouse ()
266 (if *info-click-to-select
*
267 (define-info-mouse (1) nil
'info-mouse-select-item
)
268 (define-info-mouse (1) 'info-begin-grab
'info-end-grab
))
269 (define-info-mouse (2) 'mouse-leave-info-mode
)
270 (define-info-mouse (3) 'mouse-leave-info-mode
)
271 (define-info-mouse (4) 'info-mouse-previous-line
)
272 (define-info-mouse (5) 'info-mouse-next-line
)
273 (if *info-click-to-select
*
274 (define-info-mouse ('motion
) 'info-mouse-motion-click nil
)
275 (define-info-mouse ('motion
) 'info-mouse-motion-drag nil
)))
277 (add-hook *binding-hook
* 'set-default-info-mouse
)
282 (define-handler info-mode
:key-press
(code state
)
283 (funcall-key-from-code *info-keys
* code state info
))
285 (define-handler info-mode
:motion-notify
(window root-x root-y
)
286 (unless (compress-motion-notify)
287 (funcall-button-from-code *info-mouse
* 'motion
(modifiers->state
*default-modifiers
*)
288 window root-x root-y
*fun-press
* (list info
))))
290 (define-handler info-mode
:button-press
(window root-x root-y code state
)
291 (funcall-button-from-code *info-mouse
* code state window root-x root-y
*fun-press
* (list info
)))
293 (define-handler info-mode
:button-release
(window root-x root-y code state
)
294 (funcall-button-from-code *info-mouse
* code state window root-x root-y
*fun-release
* (list info
)))
298 (defun info-mode (info-list &key
(width nil
) (height nil
))
299 "Open the info mode. Info-list is a list of info: One string per line
300 Or for colored output: a list (line_string color)
301 Or ((1_word color) (2_word color) 3_word (4_word color)...)"
303 (setf *info-selected-item
* 0)
304 (labels ((compute-size (line)
306 (cons (typecase (first line
)
309 (incf val
(typecase l
310 (cons (length (first l
)))
312 (t (length (first line
)))))
314 (let* ((font (xlib:open-font
*display
* *info-font-string
*))
315 (ilw (xlib:max-char-width font
))
316 (ilh (+ (xlib:max-char-ascent font
) (xlib:max-char-descent font
) 1))
318 (min (* (+ (loop for l in info-list maximize
(compute-size l
)) 2) ilw
)
319 (xlib:screen-width
*screen
*))))
321 (min (round (+ (* (length info-list
) ilh
) (/ ilh
2)))
322 (xlib:screen-height
*screen
*)))))
323 (with-placement (*info-mode-placement
* x y width height
)
324 (let* ((window (xlib:create-window
:parent
*root
*
328 :background
(get-color *info-background
*)
329 :colormap
(xlib:screen-default-colormap
*screen
*)
330 :border-width
*border-size
*
331 :border
(get-color *info-border
*)
332 :event-mask
'(:exposure
)))
333 (gc (xlib:create-gcontext
:drawable window
334 :foreground
(get-color *info-foreground
*)
335 :background
(get-color *info-background
*)
337 :line-style
:solid
)))
338 (setf info
(make-info :window window
:gc gc
:x
0 :y
0 :list info-list
339 :font font
:ilw ilw
:ilh ilh
340 :max-x
(* (loop for l in info-list maximize
(compute-size l
)) ilw
)
341 :max-y
(* (length info-list
) ilh
)))
342 (setf (window-transparency window
) *info-transparency
*)
344 (draw-info-window info
)
345 (wait-no-key-or-button-press)
346 (with-grab-keyboard-and-pointer (68 69 66 67)
347 (generic-mode 'info-mode
'exit-info-loop
348 :loop-function
(lambda ()
349 (raise-window (info-window info
)))
350 :original-mode
'(main-mode)))
351 (xlib:free-gcontext gc
)
352 (xlib:destroy-window window
)
353 (xlib:close-font font
)
354 (xlib:display-finish-output
*display
*)
355 (display-all-frame-info)
356 (wait-no-key-or-button-press)
357 *info-selected-item
*)))))))
361 (defun info-mode-menu (item-list &key
(width nil
) (height nil
))
362 "Open an info help menu.
363 Item-list is: '((key function) separator (key function))
364 or with explicit docstring: '((key function \"documentation 1\") (key function \"bla bla\") (key function))
365 key is a character, a keycode or a keysym
366 Separator is a string or a symbol (all but a list)
367 Function can be a function or a list (function color) for colored output"
368 (let ((info-list nil
)
370 (old-info-keys (copy-hash-table *info-keys
*)))
371 (labels ((define-key (key function
)
372 (define-info-key-fun (list key
)
373 (lambda (&optional args
)
374 (declare (ignore args
))
375 (setf action function
)
376 (leave-info-mode nil
)))))
377 (dolist (item item-list
)
379 (cons (destructuring-bind (key function explicit-doc
) (ensure-n-elems item
3)
381 (cons (push (list (list (format nil
"~A" key
) *menu-color-menu-key
*)
382 (list (format nil
": ~A" (or explicit-doc
(documentation (first function
) 'function
)))
385 (define-key key
(first function
)))
386 (t (push (list (list (format nil
"~A" key
) *menu-color-key
*)
387 (format nil
": ~A" (or explicit-doc
(documentation function
'function
))))
389 (define-key key function
)))))
390 (t (push (list (format nil
"-=- ~A -=-" item
) *menu-color-comment
*) info-list
))))
391 (let ((selected-item (info-mode (nreverse info-list
) :width width
:height height
)))
392 (setf *info-keys
* old-info-keys
)
394 (awhen (nth selected-item item-list
)
396 (destructuring-bind (key function explicit-doc
) (ensure-n-elems it
3)
397 (declare (ignore key explicit-doc
))
399 (cons (setf action
(first function
)))
400 (t (setf action function
)))))))
402 (function (funcall action
))
403 (symbol (when (fboundp action
)
404 (funcall action
))))))))
410 (defun keys-from-list (list)
411 "Produce a key menu based on list item"
414 collect
(list (number->char i
) l
)))
418 ;;;| CONFIG - Info mode functions
420 (defun key-binding-colorize-line (list)
421 (loop :for line
:in list
422 :collect
(cond ((search "* CLFSWM Keys *" line
) (list line
*info-color-title
*))
423 ((search "---" line
) (list line
*info-color-underline
*))
424 ((begin-with-2-spaces line
)
425 (list (list (subseq line
0 22) *info-color-second
*)
426 (list (subseq line
22 35) *info-color-first
*)
431 (defun show-key-binding (&rest hash-table-key
)
432 "Show the binding of each hash-table-key.
433 Pass the :no-producing-doc symbol to remove the producing doc"
434 (info-mode (key-binding-colorize-line
435 (split-string (append-newline-space
436 (with-output-to-string (stream)
437 (produce-doc (remove :no-producing-doc hash-table-key
)
439 (not (member :no-producing-doc hash-table-key
)))))
443 (defun show-global-key-binding ()
444 "Show all key binding"
445 (show-key-binding *main-keys
* *main-mouse
* *second-keys
* *second-mouse
*
446 *info-keys
* *info-mouse
*))
448 (defun show-main-mode-key-binding ()
449 "Show the main mode binding"
450 (show-key-binding *main-keys
* *main-mouse
*))
452 (defun show-second-mode-key-binding ()
453 "Show the second mode key binding"
454 (show-key-binding *second-keys
* *second-mouse
*))
456 (defun show-circulate-mode-key-binding ()
457 "Show the circulate mode key binding"
458 (show-key-binding *circulate-keys
*))
460 (defun show-expose-window-mode-key-binding ()
461 "Show the expose window mode key binding"
462 (show-key-binding *expose-keys
* *expose-mouse
*))
465 (defun show-first-aid-kit ()
466 "Show the first aid kit key binding"
467 (labels ((add-key (hash symbol
&optional
(hashkey *main-keys
*))
468 (multiple-value-bind (k v
)
469 (find-in-hash symbol hashkey
)
470 (setf (gethash k hash
) v
))))
471 (let ((hash (make-hash-table :test
#'equal
))
472 (hash-second (make-hash-table :test
#'equal
)))
473 (setf (gethash 'name hash
) "First aid kit - Main mode key binding"
474 (gethash 'name hash-second
) "First aid kit - Second mode key binding")
475 (add-key hash
'select-next-child
)
476 (add-key hash
'select-previous-child
)
477 (add-key hash
'select-next-brother
)
478 (add-key hash
'select-previous-brother
)
479 (add-key hash
'select-previous-level
)
480 (add-key hash
'select-next-level
)
481 (add-key hash
'enter-frame
)
482 (add-key hash
'leave-frame
)
483 (add-key hash
'second-key-mode
)
484 (add-key hash
'expose-windows-mode
)
485 (add-key hash
'expose-all-windows-mode
)
486 (add-key hash
'present-clfswm-terminal
)
487 (add-key hash-second
'leave-second-mode
*second-keys
*)
488 (add-key hash-second
'open-menu
*second-keys
*)
489 (add-key hash-second
'run-program-from-query-string
*second-keys
*)
490 (add-key hash-second
'eval-from-query-string
*second-keys
*)
491 (add-key hash-second
'set-open-in-new-frame-in-parent-frame-nw-hook
*second-keys
*)
492 (add-key hash-second
'b-start-xterm
*second-keys
*)
493 (add-key hash-second
'b-start-emacs
*second-keys
*)
494 (show-key-binding hash hash-second
:no-producing-doc
))))
497 (defun corner-help-colorize-line (list)
498 (loop :for line
:in list
499 :collect
(cond ((search "CLFSWM:" line
) (list line
*info-color-title
*))
500 ((search "*:" line
) (list line
*info-color-underline
*))
501 ((begin-with-2-spaces line
)
502 (let ((pos (position #\
: line
)))
504 (list (list (subseq line
0 (1+ pos
)) *info-color-first
*)
505 (subseq line
(1+ pos
)))
509 (defun show-corner-help ()
510 "Help on clfswm corner"
511 (info-mode (corner-help-colorize-line
512 (split-string (append-newline-space
513 (with-output-to-string (stream)
514 (produce-corner-doc stream
)))
518 (defun configuration-variable-colorize-line (list)
519 (loop :for line
:in list
520 :collect
(cond ((search "CLFSWM " line
) (list line
*info-color-title
*))
522 (let ((pos (position #\
= line
)))
523 (list (list (subseq line
0 (1+ pos
)) *info-color-first
*)
524 (list (subseq line
(1+ pos
)) *info-color-second
*))))
525 ((search "<=" line
) (list line
*info-color-underline
*))
529 (defun show-config-variable ()
530 "Show all configurable variables"
534 (info-mode-menu (loop :for group
:in
(config-all-groups)
536 :collect
(list (number->char i
)
539 (setf result group
)))
540 (config-group->string group
))))
542 (info-mode (configuration-variable-colorize-line
543 (split-string (append-newline-space
544 (with-output-to-string (stream)
545 (produce-conf-var-doc stream result t nil
)))
554 "Show the current time and date"
555 (info-mode (list (list `("Current date:" ,*menu-color-comment
*) (date-string)))))
562 (defun info-on-shell (msg program
)
563 (let ((lines (do-shell program nil t
)))
564 (info-mode (append (list (list msg
*menu-color-comment
*))
565 (loop for line
= (read-line lines nil nil
)
567 collect
(ensure-printable line
))))))
571 (defun show-cpu-proc ()
572 "Show current processes sorted by CPU usage"
573 (info-on-shell "Current processes sorted by CPU usage:"
574 "ps --cols=1000 --sort='-%cpu,uid,pgid,ppid,pid' -e -o user,pid,stime,pcpu,pmem,args"))
576 (defun show-mem-proc ()
577 "Show current processes sorted by memory usage"
578 (info-on-shell "Current processes sorted by MEMORY usage:"
579 "ps --cols=1000 --sort='-vsz,uid,pgid,ppid,pid' -e -o user,pid,stime,pcpu,pmem,args"))
582 (defun show-cd-info ()
583 "Show the current CD track"
584 (info-on-shell "Current CD track:" "pcd i"))
586 (defun show-cd-playlist ()
587 "Show the current CD playlist"
588 (info-on-shell "Current CD playlist:" "pcd mi"))
591 (defun show-version ()
592 "Show the current CLFSWM version"
593 (info-mode (list *version
*)))