1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Info function (see the end of this file for user definition
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2011 Philippe Brochard <hocwp@free.fr>
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* ((pointer-grabbed-p (xgrab-pointer-p))
325 (keyboard-grabbed-p (xgrab-keyboard-p))
326 (window (xlib:create-window
:parent
*root
*
330 :background
(get-color *info-background
*)
331 :colormap
(xlib:screen-default-colormap
*screen
*)
332 :border-width
*border-size
*
333 :border
(get-color *info-border
*)
334 :event-mask
'(:exposure
)))
335 (gc (xlib:create-gcontext
:drawable window
336 :foreground
(get-color *info-foreground
*)
337 :background
(get-color *info-background
*)
339 :line-style
:solid
)))
340 (setf info
(make-info :window window
:gc gc
:x
0 :y
0 :list info-list
341 :font font
:ilw ilw
:ilh ilh
342 :max-x
(* (loop for l in info-list maximize
(compute-size l
)) ilw
)
343 :max-y
(* (length info-list
) ilh
)))
344 (setf (window-transparency window
) *info-transparency
*)
346 (draw-info-window info
)
347 (xgrab-pointer *root
* 68 69)
348 (unless keyboard-grabbed-p
349 (xgrab-keyboard *root
*))
350 (wait-no-key-or-button-press)
351 (generic-mode 'info-mode
'exit-info-loop
352 :loop-function
(lambda ()
353 (raise-window (info-window info
)))
354 :original-mode
'(main-mode))
355 (if pointer-grabbed-p
356 (xgrab-pointer *root
* 66 67)
358 (unless keyboard-grabbed-p
360 (xlib:free-gcontext gc
)
361 (xlib:destroy-window window
)
362 (xlib:close-font font
)
363 (xlib:display-finish-output
*display
*)
364 (display-all-frame-info)
365 (wait-no-key-or-button-press)
366 *info-selected-item
*)))))))
370 (defun info-mode-menu (item-list &key
(width nil
) (height nil
))
371 "Open an info help menu.
372 Item-list is: '((key function) separator (key function))
373 or with explicit docstring: '((key function \"documentation 1\") (key function \"bla bla\") (key function))
374 key is a character, a keycode or a keysym
375 Separator is a string or a symbol (all but a list)
376 Function can be a function or a list (function color) for colored output"
377 (let ((info-list nil
)
379 (old-info-keys (copy-hash-table *info-keys
*)))
380 (labels ((define-key (key function
)
381 (define-info-key-fun (list key
)
382 (lambda (&optional args
)
383 (declare (ignore args
))
384 (setf action function
)
385 (leave-info-mode nil
)))))
386 (dolist (item item-list
)
388 (cons (destructuring-bind (key function explicit-doc
) (ensure-n-elems item
3)
390 (cons (push (list (list (format nil
"~A" key
) *menu-color-menu-key
*)
391 (list (format nil
": ~A" (or explicit-doc
(documentation (first function
) 'function
)))
394 (define-key key
(first function
)))
395 (t (push (list (list (format nil
"~A" key
) *menu-color-key
*)
396 (format nil
": ~A" (or explicit-doc
(documentation function
'function
))))
398 (define-key key function
)))))
399 (t (push (list (format nil
"-=- ~A -=-" item
) *menu-color-comment
*) info-list
))))
400 (let ((selected-item (info-mode (nreverse info-list
) :width width
:height height
)))
401 (setf *info-keys
* old-info-keys
)
403 (awhen (nth selected-item item-list
)
405 (destructuring-bind (key function explicit-doc
) (ensure-n-elems it
3)
406 (declare (ignore key explicit-doc
))
408 (cons (setf action
(first function
)))
409 (t (setf action function
)))))))
411 (function (funcall action
))
412 (symbol (when (fboundp action
)
413 (funcall action
))))))))
419 (defun keys-from-list (list)
420 "Produce a key menu based on list item"
423 collect
(list (number->char i
) l
)))
427 ;;;| CONFIG - Info mode functions
429 (defun key-binding-colorize-line (list)
430 (loop :for line
:in list
431 :collect
(cond ((search "* CLFSWM Keys *" line
) (list line
*info-color-title
*))
432 ((search "---" line
) (list line
*info-color-underline
*))
433 ((begin-with-2-spaces line
)
434 (list (list (subseq line
0 22) *info-color-second
*)
435 (list (subseq line
22 35) *info-color-first
*)
440 (defun show-key-binding (&rest hash-table-key
)
441 "Show the binding of each hash-table-key.
442 Pass the :no-producing-doc symbol to remove the producing doc"
443 (info-mode (key-binding-colorize-line
444 (split-string (append-newline-space
445 (with-output-to-string (stream)
446 (produce-doc (remove :no-producing-doc hash-table-key
)
448 (not (member :no-producing-doc hash-table-key
)))))
452 (defun show-global-key-binding ()
453 "Show all key binding"
454 (show-key-binding *main-keys
* *main-mouse
* *second-keys
* *second-mouse
*
455 *info-keys
* *info-mouse
*))
457 (defun show-main-mode-key-binding ()
458 "Show the main mode binding"
459 (show-key-binding *main-keys
* *main-mouse
*))
461 (defun show-second-mode-key-binding ()
462 "Show the second mode key binding"
463 (show-key-binding *second-keys
* *second-mouse
*))
465 (defun show-circulate-mode-key-binding ()
466 "Show the circulate mode key binding"
467 (show-key-binding *circulate-keys
*))
469 (defun show-expose-window-mode-key-binding ()
470 "Show the expose window mode key binding"
471 (show-key-binding *expose-keys
* *expose-mouse
*))
474 (defun show-first-aid-kit ()
475 "Show the first aid kit key binding"
476 (labels ((add-key (hash symbol
&optional
(hashkey *main-keys
*))
477 (multiple-value-bind (k v
)
478 (find-in-hash symbol hashkey
)
479 (setf (gethash k hash
) v
))))
480 (let ((hash (make-hash-table :test
#'equal
))
481 (hash-second (make-hash-table :test
#'equal
)))
482 (setf (gethash 'name hash
) "First aid kit - Main mode key binding"
483 (gethash 'name hash-second
) "First aid kit - Second mode key binding")
484 (add-key hash
'select-next-child
)
485 (add-key hash
'select-previous-child
)
486 (add-key hash
'select-next-brother
)
487 (add-key hash
'select-previous-brother
)
488 (add-key hash
'select-previous-level
)
489 (add-key hash
'select-next-level
)
490 (add-key hash
'enter-frame
)
491 (add-key hash
'leave-frame
)
492 (add-key hash
'second-key-mode
)
493 (add-key hash
'expose-windows-mode
)
494 (add-key hash
'expose-all-windows-mode
)
495 (add-key hash
'present-clfswm-terminal
)
496 (add-key hash-second
'leave-second-mode
*second-keys
*)
497 (add-key hash-second
'open-menu
*second-keys
*)
498 (add-key hash-second
'run-program-from-query-string
*second-keys
*)
499 (add-key hash-second
'eval-from-query-string
*second-keys
*)
500 (add-key hash-second
'set-open-in-new-frame-in-parent-frame-nw-hook
*second-keys
*)
501 (add-key hash-second
'b-start-xterm
*second-keys
*)
502 (add-key hash-second
'b-start-emacs
*second-keys
*)
503 (show-key-binding hash hash-second
:no-producing-doc
))))
506 (defun corner-help-colorize-line (list)
507 (loop :for line
:in list
508 :collect
(cond ((search "CLFSWM:" line
) (list line
*info-color-title
*))
509 ((search "*:" line
) (list line
*info-color-underline
*))
510 ((begin-with-2-spaces line
)
511 (let ((pos (position #\
: line
)))
513 (list (list (subseq line
0 (1+ pos
)) *info-color-first
*)
514 (subseq line
(1+ pos
)))
518 (defun show-corner-help ()
519 "Help on clfswm corner"
520 (info-mode (corner-help-colorize-line
521 (split-string (append-newline-space
522 (with-output-to-string (stream)
523 (produce-corner-doc stream
)))
527 (defun configuration-variable-colorize-line (list)
528 (loop :for line
:in list
529 :collect
(cond ((search "CLFSWM " line
) (list line
*info-color-title
*))
531 (let ((pos (position #\
= line
)))
532 (list (list (subseq line
0 (1+ pos
)) *info-color-first
*)
533 (list (subseq line
(1+ pos
)) *info-color-second
*))))
534 ((search "<=" line
) (list line
*info-color-underline
*))
538 (defun show-config-variable ()
539 "Show all configurable variables"
543 (info-mode-menu (loop :for group
:in
(config-all-groups)
545 :collect
(list (number->char i
)
548 (setf result group
)))
549 (config-group->string group
))))
551 (info-mode (configuration-variable-colorize-line
552 (split-string (append-newline-space
553 (with-output-to-string (stream)
554 (produce-conf-var-doc stream result t nil
)))
563 "Show the current time and date"
564 (info-mode (list (list `("Current date:" ,*menu-color-comment
*) (date-string)))))
571 (defun info-on-shell (msg program
)
572 (let ((lines (do-shell program nil t
)))
573 (info-mode (append (list (list msg
*menu-color-comment
*))
574 (loop for line
= (read-line lines nil nil
)
580 (defun show-cpu-proc ()
581 "Show current processes sorted by CPU usage"
582 (info-on-shell "Current processes sorted by CPU usage:"
583 "ps --cols=1000 --sort='-%cpu,uid,pgid,ppid,pid' -e -o user,pid,stime,pcpu,pmem,args"))
585 (defun show-mem-proc ()
586 "Show current processes sorted by memory usage"
587 (info-on-shell "Current processes sorted by MEMORY usage:"
588 "ps --cols=1000 --sort='-vsz,uid,pgid,ppid,pid' -e -o user,pid,stime,pcpu,pmem,args"))
591 (defun show-cd-info ()
592 "Show the current CD track"
593 (info-on-shell "Current CD track:" "pcd i"))
595 (defun show-cd-playlist ()
596 "Show the current CD playlist"
597 (info-on-shell "Current CD playlist:" "pcd mi"))
600 (defun show-version ()
601 "Show the current CLFSWM version"
602 (info-mode (list *version
*)))