1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Query utility
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2010 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 ;;; --------------------------------------------------------------------------
29 (defparameter *query-window
* nil
)
30 (defparameter *query-font
* nil
)
31 (defparameter *query-gc
* nil
)
33 (defparameter *query-history
* nil
)
35 (defparameter *query-message
* nil
)
36 (defparameter *query-string
* nil
)
37 (defparameter *query-pos
* nil
)
38 (defparameter *query-return
* nil
)
42 (defun query-show-paren (orig-string pos dec
)
43 "Replace matching parentheses with brackets"
44 (let ((string (copy-seq orig-string
)))
45 (labels ((have-to-find-right?
()
46 (and (< pos
(length string
)) (char= (aref string pos
) #\
()))
47 (have-to-find-left?
()
48 (and (> (1- pos
) 0) (char= (aref string
(1- pos
)) #\
))))
50 (loop :for p
:from
(1+ pos
) :below
(length string
)
51 :with level
= 1 :for c
= (aref string p
)
52 :do
(when (char= c
#\
() (incf level
))
53 (when (char= c
#\
)) (decf level
))
54 (when (= level
0) (return p
))))
56 (loop :for p
:from
(- pos
2) :downto
0
57 :with level
= 1 :for c
= (aref string p
)
58 :do
(when (char= c
#\
() (decf level
))
59 (when (char= c
#\
)) (incf level
))
60 (when (= level
0) (return p
))))
61 (draw-bloc (p &optional
(color *query-parent-color
*))
62 (setf (xlib:gcontext-foreground
*query-gc
*) (get-color color
))
63 (xlib:draw-rectangle
*pixmap-buffer
* *query-gc
*
64 (+ 10 (* p
(xlib:max-char-width
*query-font
*)) dec
)
65 (+ (xlib:max-char-ascent
*query-font
*) (xlib:max-char-descent
*query-font
*) 7)
66 (xlib:max-char-width
*query-font
*)
67 (+ (xlib:max-char-ascent
*query-font
*) (xlib:max-char-descent
*query-font
*))
69 (cond ((have-to-find-left?
) (let ((p (pos-left)))
71 (progn (draw-bloc p
) (draw-bloc (1- pos
)))
72 (draw-bloc (1- pos
) *query-parent-error-color
*))))
73 ((have-to-find-right?
) (let ((p (pos-right)))
75 (progn (draw-bloc p
) (draw-bloc pos
))
76 (draw-bloc pos
*query-parent-error-color
*))))))))
79 (defun clear-query-history ()
80 "Clear the query-string history"
81 (setf *query-history
* nil
))
85 (defun leave-query-mode (&optional
(return :Escape
))
86 "Leave the query mode"
87 (setf *query-return
* return
)
88 (throw 'exit-query-loop nil
))
91 (defun leave-query-mode-valid ()
92 (leave-query-mode :Return
))
94 (defun leave-query-mode-complet ()
95 (leave-query-mode :Complet
))
97 (add-hook *binding-hook
* 'init-
*query-keys
*)
100 (defun query-print-string ()
101 (let ((dec (min 0 (- (- (xlib:drawable-width
*query-window
*) 10)
102 (+ 10 (* *query-pos
* (xlib:max-char-width
*query-font
*)))))))
103 (clear-pixmap-buffer *query-window
* *query-gc
*)
104 (setf (xlib:gcontext-foreground
*query-gc
*) (get-color *query-message-color
*))
105 (xlib:draw-glyphs
*pixmap-buffer
* *query-gc
* 5 (+ (xlib:max-char-ascent
*query-font
*) 5) *query-message
*)
106 (when (< *query-pos
* 0)
107 (setf *query-pos
* 0))
108 (when (> *query-pos
* (length *query-string
*))
109 (setf *query-pos
* (length *query-string
*)))
110 (query-show-paren *query-string
* *query-pos
* dec
)
111 (setf (xlib:gcontext-foreground
*query-gc
*) (get-color *query-foreground
*))
112 (xlib:draw-glyphs
*pixmap-buffer
* *query-gc
*
114 (+ (* 2 (+ (xlib:max-char-ascent
*query-font
*) (xlib:max-char-descent
*query-font
*))) 5)
116 (setf (xlib:gcontext-foreground
*query-gc
*) (get-color *query-cursor-color
*))
117 (xlib:draw-line
*pixmap-buffer
* *query-gc
*
118 (+ 10 (* *query-pos
* (xlib:max-char-width
*query-font
*)) dec
)
119 (+ (* 2 (+ (xlib:max-char-ascent
*query-font
*) (xlib:max-char-descent
*query-font
*))) 6)
120 (+ 10 (* *query-pos
* (xlib:max-char-width
*query-font
*)) dec
)
121 (+ (* 1 (+ (xlib:max-char-ascent
*query-font
*) (xlib:max-char-descent
*query-font
*))) 7))
122 (copy-pixmap-buffer *query-window
* *query-gc
*)))
126 (defun query-enter-function ()
127 (setf *query-font
* (xlib:open-font
*display
* *query-font-string
*))
128 (let ((width (- (xlib:screen-width
*screen
*) 2))
129 (height (* 3 (+ (xlib:max-char-ascent
*query-font
*) (xlib:max-char-descent
*query-font
*)))))
130 (with-placement (*query-mode-placement
* x y width height
)
131 (setf *query-window
* (xlib:create-window
:parent
*root
*
135 :background
(get-color *query-background
*)
137 :border
(get-color *query-border
*)
138 :colormap
(xlib:screen-default-colormap
*screen
*)
139 :event-mask
'(:exposure
:key-press
))
140 *query-gc
* (xlib:create-gcontext
:drawable
*query-window
*
141 :foreground
(get-color *query-foreground
*)
142 :background
(get-color *query-background
*)
145 (map-window *query-window
*)
147 (wait-no-key-or-button-press))))
151 (defun query-leave-function ()
152 (xlib:destroy-window
*query-window
*)
153 (xlib:close-font
*query-font
*)
154 (wait-no-key-or-button-press))
156 (defun query-loop-function ()
157 (raise-window *query-window
*))
161 (labels ((generic-backspace (del-pos)
163 (setf *query-string
* (concatenate 'string
164 (subseq *query-string
* 0 del-pos
)
165 (subseq *query-string
* *query-pos
*))
166 *query-pos
* del-pos
))))
167 (defun query-backspace ()
168 "Delete a character backward"
169 (generic-backspace (1- *query-pos
*)))
171 (defun query-backspace-word ()
172 "Delete a word backward"
173 (generic-backspace (or (position #\Space
*query-string
* :from-end t
:end
*query-pos
*) 0))))
176 (labels ((generic-delete (del-pos)
177 (when (<= del-pos
(length *query-string
*))
178 (setf *query-string
* (concatenate 'string
179 (subseq *query-string
* 0 *query-pos
*)
180 (subseq *query-string
* del-pos
))))))
181 (defun query-delete ()
182 "Delete a character forward"
183 (generic-delete (1+ *query-pos
*)))
185 (defun query-delete-word ()
186 "Delete a word forward"
187 (generic-delete (1+ (or (position #\Space
*query-string
* :start
*query-pos
*)
188 (1- (length *query-string
*)))))))
193 "Move cursor to line begining"
194 (setf *query-pos
* 0))
197 "Move cursor to line end"
198 (setf *query-pos
* (length *query-string
*)))
202 "Move cursor to left"
203 (when (> *query-pos
* 0)
204 (setf *query-pos
* (1- *query-pos
*))))
206 (defun query-left-word ()
207 "Move cursor to left word"
208 (when (> *query-pos
* 0)
209 (setf *query-pos
* (let ((p (position #\Space
*query-string
*
210 :end
(min (1- *query-pos
*) (length *query-string
*))
214 (defun query-right ()
215 "Move cursor to right"
216 (when (< *query-pos
* (length *query-string
*))
217 (setf *query-pos
* (1+ *query-pos
*))))
219 (defun query-right-word ()
220 "Move cursor to right word"
221 (when (< *query-pos
* (length *query-string
*))
222 (setf *query-pos
* (let ((p (position #\Space
*query-string
*
223 :start
(min (1+ *query-pos
*) (length *query-string
*)))))
224 (if p p
(length *query-string
*))))))
226 (defun query-previous-history ()
227 "Circulate backward in history"
228 (setf *query-string
* (first *query-history
*)
229 *query-pos
* (length *query-string
*)
230 *query-history
* (rotate-list *query-history
*)))
233 (defun query-next-history ()
234 "Circulate forward in history"
235 (setf *query-string
* (first *query-history
*)
236 *query-pos
* (length *query-string
*)
237 *query-history
* (anti-rotate-list *query-history
*)))
241 (defun query-delete-eof ()
242 "Delete the end of the line"
243 (setf *query-string
* (subseq *query-string
* 0 *query-pos
*)))
246 (add-hook *binding-hook
* 'set-default-query-keys
)
248 (defun set-default-query-keys ()
249 (define-query-key ("Return") 'leave-query-mode-valid
)
250 (define-query-key ("Escape") 'leave-query-mode
)
251 (define-query-key ("g" :control
) 'leave-query-mode
)
252 (define-query-key ("Tab") 'leave-query-mode-complet
)
253 (define-query-key ("BackSpace") 'query-backspace
)
254 (define-query-key ("BackSpace" :control
) 'query-backspace-word
)
255 (define-query-key ("Delete") 'query-delete
)
256 (define-query-key ("Delete" :control
) 'query-delete-word
)
257 (define-query-key ("Home") 'query-home
)
258 (define-query-key ("End") 'query-end
)
259 (define-query-key ("Left") 'query-left
)
260 (define-query-key ("Left" :control
) 'query-left-word
)
261 (define-query-key ("Right") 'query-right
)
262 (define-query-key ("Right" :control
) 'query-right-word
)
263 (define-query-key ("Up") 'query-previous-history
)
264 (define-query-key ("Down") 'query-next-history
)
265 (define-query-key ("k" :control
) 'query-delete-eof
))
269 (defun add-in-query-string (code state
)
270 (let* ((modifiers (state->modifiers state
))
271 (keysym (keycode->keysym code modifiers
))
272 (char (xlib:keysym-
>character
*display
* keysym state
)))
273 (when (and char
(characterp char
))
274 (setf *query-string
* (concatenate 'string
275 (when (<= *query-pos
* (length *query-string
*))
276 (subseq *query-string
* 0 *query-pos
*))
278 (when (< *query-pos
* (length *query-string
*))
279 (subseq *query-string
* *query-pos
*))))
280 (incf *query-pos
*))))
284 (define-handler query-mode
:key-press
(code state
)
285 (unless (funcall-key-from-code *query-keys
* code state
)
286 (add-in-query-string code state
))
287 (query-print-string))
291 (defun query-string (message &optional
(default ""))
292 "Query a string from the keyboard. Display msg as prompt"
293 (let ((grab-keyboard-p (xgrab-keyboard-p))
294 (grab-pointer-p (xgrab-pointer-p)))
295 (setf *query-message
* message
296 *query-string
* default
297 *query-pos
* (length default
))
298 (xgrab-pointer *root
* 92 93)
299 (unless grab-keyboard-p
301 (xgrab-keyboard *root
*))
302 (generic-mode 'query-mode
'exit-query-loop
303 :enter-function
#'query-enter-function
304 :loop-function
#'query-loop-function
305 :leave-function
#'query-leave-function
306 :original-mode
'(main-mode))
307 (unless grab-keyboard-p
311 (xgrab-pointer *root
* 66 67)
313 (when (member *query-return
* '(:Return
:Complet
))
314 (pushnew default
*query-history
* :test
#'equal
)
315 (push *query-string
* *query-history
*))
316 (values *query-string
*
321 (defun query-number (msg &optional
(default 0))
322 "Query a number from the query input"
323 (parse-integer (or (query-string msg
(format nil
"~A" default
)) "") :junk-allowed t
))