[clfswm-cvs] r213 - in clfswm: . src
Philippe Brochard
pbrochard at common-lisp.net
Wed Apr 22 20:39:09 UTC 2009
Author: pbrochard
Date: Wed Apr 22 16:39:09 2009
New Revision: 213
Log:
Use a generic mode for query-string
Modified:
clfswm/ChangeLog
clfswm/clfswm.asd
clfswm/src/clfswm-generic-mode.lisp
clfswm/src/clfswm-info.lisp
clfswm/src/clfswm-keys.lisp
clfswm/src/clfswm-query.lisp
clfswm/src/clfswm-second-mode.lisp
clfswm/src/package.lisp
Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog (original)
+++ clfswm/ChangeLog Wed Apr 22 16:39:09 2009
@@ -1,3 +1,7 @@
+2009-04-22 Xavier Maillard <xma at gnu.org>
+
+ * src/clfswm-query.lisp (query-string): Use a generic mode.
+
2009-04-19 Xavier Maillard <xma at gnu.org>
* src/clfswm-info.lisp (info-mode): Use generic-mode for info-mode.
Modified: clfswm/clfswm.asd
==============================================================================
--- clfswm/clfswm.asd (original)
+++ clfswm/clfswm.asd Wed Apr 22 16:39:09 2009
@@ -49,7 +49,8 @@
(:file "clfswm-menu"
:depends-on ("package" "clfswm-info"))
(:file "clfswm-query"
- :depends-on ("package" "config" "xlib-util"))
+ :depends-on ("package" "config" "xlib-util" "clfswm-keys"
+ "clfswm-generic-mode"))
(:file "clfswm-util"
:depends-on ("clfswm" "keysyms" "clfswm-info" "clfswm-second-mode" "clfswm-query" "clfswm-menu" "clfswm-autodoc" "clfswm-corner"))
(:file "clfswm-layout"
Modified: clfswm/src/clfswm-generic-mode.lisp
==============================================================================
--- clfswm/src/clfswm-generic-mode.lisp (original)
+++ clfswm/src/clfswm-generic-mode.lisp Wed Apr 22 16:39:09 2009
@@ -26,7 +26,7 @@
(in-package :clfswm)
-(defun generic-mode (&key enter-function loop-function leave-function
+(defun generic-mode (exit-tag &key enter-function loop-function leave-function
(button-press-hook *button-press-hook*)
(button-release-hook *button-release-hook*)
(motion-notify-hook *motion-notify-hook*)
@@ -67,7 +67,7 @@
t))
(nfuncall enter-function)
(unwind-protect
- (catch 'exit-second-loop
+ (catch exit-tag
(loop
(nfuncall loop-function)
(xlib:display-finish-output *display*)
Modified: clfswm/src/clfswm-info.lisp
==============================================================================
--- clfswm/src/clfswm-info.lisp (original)
+++ clfswm/src/clfswm-info.lisp Wed Apr 22 16:39:09 2009
@@ -242,37 +242,30 @@
(funcall-button-from-code *info-mouse* code state window root-x root-y *fun-press* (list info)))
(handle-button-release (&rest event-slots &key window root-x root-y code state &allow-other-keys)
(declare (ignore event-slots))
- (funcall-button-from-code *info-mouse* code state window root-x root-y *fun-release* (list info)))
- (info-handle-unmap-notify (&rest event-slots)
- (apply #'handle-unmap-notify event-slots)
- (draw-info-window info))
- (info-handle-destroy-notify (&rest event-slots)
- (apply #'handle-destroy-notify event-slots)
- (draw-info-window info)))
+ (funcall-button-from-code *info-mouse* code state window root-x root-y *fun-release* (list info))))
(xlib:map-window window)
(draw-info-window info)
(xgrab-pointer *root* 68 69)
(unless keyboard-grabbed-p
(xgrab-keyboard *root*))
- (unwind-protect
- (catch 'exit-info-loop
- (generic-mode :loop-function (lambda ()
- (raise-window (info-window info))
- (draw-info-window info))
- :button-press-hook #'handle-button-press
- :button-release-hook #'handle-button-release
- :motion-notify-hook #'handle-motion-notify
- :key-press-hook #'handle-key))
- (if pointer-grabbed-p
- (xgrab-pointer *root* 66 67)
- (xungrab-pointer))
- (unless keyboard-grabbed-p
- (xungrab-keyboard))
- (xlib:free-gcontext gc)
- (xlib:destroy-window window)
- (xlib:close-font font)
- (display-all-frame-info)
- (wait-no-key-or-button-press)))))))
+ (generic-mode 'exit-info-loop
+ :loop-function (lambda ()
+ (raise-window (info-window info))
+ (draw-info-window info))
+ :button-press-hook #'handle-button-press
+ :button-release-hook #'handle-button-release
+ :motion-notify-hook #'handle-motion-notify
+ :key-press-hook #'handle-key)
+ (if pointer-grabbed-p
+ (xgrab-pointer *root* 66 67)
+ (xungrab-pointer))
+ (unless keyboard-grabbed-p
+ (xungrab-keyboard))
+ (xlib:free-gcontext gc)
+ (xlib:destroy-window window)
+ (xlib:close-font font)
+ (display-all-frame-info)
+ (wait-no-key-or-button-press))))))
Modified: clfswm/src/clfswm-keys.lisp
==============================================================================
--- clfswm/src/clfswm-keys.lisp (original)
+++ clfswm/src/clfswm-keys.lisp Wed Apr 22 16:39:09 2009
@@ -60,7 +60,7 @@
(define-init-hash-table-key *second-mouse* "Mouse buttons actions in second mode")
(define-init-hash-table-key *info-keys* "Info mode keys")
(define-init-hash-table-key *info-mouse* "Mouse buttons actions in info mode")
-
+(define-init-hash-table-key *query-keys* "Query mode keys")
(defun unalias-modifiers (list)
@@ -113,6 +113,7 @@
(define-define-key "main" *main-keys*)
(define-define-key "second" *second-keys*)
(define-define-key "info" *info-keys*)
+(define-define-key "query" *query-keys*)
(define-define-mouse "main-mouse" *main-mouse*)
(define-define-mouse "second-mouse" *second-mouse*)
Modified: clfswm/src/clfswm-query.lisp
==============================================================================
--- clfswm/src/clfswm-query.lisp (original)
+++ clfswm/src/clfswm-query.lisp Wed Apr 22 16:39:09 2009
@@ -26,6 +26,19 @@
(in-package :clfswm)
+(defparameter *query-window* nil)
+(defparameter *query-font* nil)
+(defparameter *query-gc* nil)
+
+(defparameter *query-history* nil)
+
+(defparameter *query-message* nil)
+(defparameter *query-string* nil)
+(defparameter *query-pos* nil)
+(defparameter *query-return* nil)
+
+
+
(defun query-show-paren (orig-string pos)
"Replace matching parentheses with brackets"
(let ((string (copy-seq orig-string)))
@@ -54,142 +67,234 @@
string)))
-;;; CONFIG - Query string mode
-(let ((history nil))
- (defun clear-history ()
- "Clear the query-string history"
- (setf history nil))
-
- (defun query-string (msg &optional (default ""))
- "Query a string from the keyboard. Display msg as prompt"
- (let* ((done nil)
- (font (xlib:open-font *display* *query-font-string*))
- (window (xlib:create-window :parent *root*
- :x 0 :y 0
- :width (- (xlib:screen-width *screen*) 2)
- :height (* 3 (+ (xlib:max-char-ascent font) (xlib:max-char-descent font)))
- :background (get-color *query-background*)
- :border-width 1
- :border (get-color *query-border*)
- :colormap (xlib:screen-default-colormap *screen*)
- :event-mask '(:exposure)))
- (gc (xlib:create-gcontext :drawable window
- :foreground (get-color *query-foreground*)
- :background (get-color *query-background*)
- :font font
- :line-style :solid))
- (result-string default)
- (pos (length default))
- (local-history history)
- (grab-keyboard-p (xgrab-keyboard-p))
- (grab-pointer-p (xgrab-pointer-p)))
- (labels ((add-cursor (string)
- (concatenate 'string (subseq string 0 pos) "|" (subseq string pos)))
- (print-string ()
- (clear-pixmap-buffer window gc)
- (setf (xlib:gcontext-foreground gc) (get-color *query-foreground*))
- (xlib:draw-glyphs *pixmap-buffer* gc 5 (+ (xlib:max-char-ascent font) 5) msg)
- (when (< pos 0) (setf pos 0))
- (when (> pos (length result-string)) (setf pos (length result-string)))
- (xlib:draw-glyphs *pixmap-buffer* gc 10 (+ (* 2 (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) 5)
- (add-cursor (query-show-paren result-string pos)))
- (copy-pixmap-buffer window gc))
- (call-backspace (modifiers)
- (let ((del-pos (if (member :control modifiers)
- (or (position #\Space result-string :from-end t :end pos) 0)
- (1- pos))))
- (when (>= del-pos 0)
- (setf result-string (concatenate 'string
- (subseq result-string 0 del-pos)
- (subseq result-string pos))
- pos del-pos))))
- (call-delete (modifiers)
- (let ((del-pos (if (member :control modifiers)
- (1+ (or (position #\Space result-string :start pos) (1- (length result-string))))
- (1+ pos))))
- (if (<= del-pos (length result-string))
- (setf result-string (concatenate 'string
- (subseq result-string 0 pos)
- (subseq result-string del-pos))))))
- (call-delete-eof ()
- (setf result-string (subseq result-string 0 pos)))
- (handle-query-key (&rest event-slots &key root code state &allow-other-keys)
- (declare (ignore event-slots root))
- (let* ((modifiers (state->modifiers state))
- (keysym (keycode->keysym code modifiers))
- (char (xlib:keysym->character *display* keysym))
- (keysym-name (keysym->keysym-name keysym)))
- (setf done (cond ((string-equal keysym-name "Return") :Return)
- ((string-equal keysym-name "Tab") :Complet)
- ((string-equal keysym-name "Escape") :Escape)
- (t nil)))
- (cond ((string-equal keysym-name "Left")
- (when (> pos 0)
- (setf pos (if (member :control modifiers)
- (let ((p (position #\Space result-string
- :end (min (1- pos) (length result-string))
- :from-end t)))
- (if p p 0))
- (1- pos)))))
- ((string-equal keysym-name "Right")
- (when (< pos (length result-string))
- (setf pos (if (member :control modifiers)
- (let ((p (position #\Space result-string
- :start (min (1+ pos) (length result-string)))))
- (if p p (length result-string)))
- (1+ pos)))))
- ((string-equal keysym-name "Up")
- (setf result-string (first local-history)
- pos (length result-string)
- local-history (rotate-list local-history)))
- ((string-equal keysym-name "Down")
- (setf result-string (first local-history)
- pos (length result-string)
- local-history (anti-rotate-list local-history)))
- ((string-equal keysym-name "Home") (setf pos 0))
- ((string-equal keysym-name "End") (setf pos (length result-string)))
- ((string-equal keysym-name "Backspace") (call-backspace modifiers))
- ((string-equal keysym-name "Delete") (call-delete modifiers))
- ((and (string-equal keysym-name "k") (member :control modifiers))
- (call-delete-eof))
- ((and (characterp char) (standard-char-p char))
- (setf result-string (concatenate 'string
- (when (<= pos (length result-string))
- (subseq result-string 0 pos))
- (string char)
- (when (< pos (length result-string))
- (subseq result-string pos))))
- (incf pos)))
- (print-string)))
- (handle-query (&rest event-slots &key display event-key &allow-other-keys)
- (declare (ignore display))
- (case event-key
- (:key-press (apply #'handle-query-key event-slots) t)
- (:exposure (print-string)))
- t))
- (xgrab-pointer *root* 92 93)
- (unless grab-keyboard-p
- (ungrab-main-keys)
- (xgrab-keyboard *root*))
- (xlib:map-window window)
- (print-string)
- (wait-no-key-or-button-press)
- (unwind-protect
- (loop until (member done '(:Return :Escape :Complet)) do
- (xlib:display-finish-output *display*)
- (xlib:process-event *display* :handler #'handle-query))
- (xlib:destroy-window window)
- (xlib:close-font font)
- (unless grab-keyboard-p
- (xungrab-keyboard)
- (grab-main-keys))
- (if grab-pointer-p
- (xgrab-pointer *root* 66 67)
- (xungrab-pointer))))
- (values (when (member done '(:Return :Complet))
- (push result-string history)
- result-string)
- done))))
+(defun clear-query-history ()
+ "Clear the query-string history"
+ (setf *query-history* nil))
+
+
+
+(defun leave-query-mode (&optional (return :Escape))
+ "Leave the query mode"
+ (setf *query-return* return)
+ (throw 'exit-query-loop nil))
+
+(defun leave-query-mode-valid ()
+ (leave-query-mode :Return))
+
+(defun leave-query-mode-complet ()
+ (leave-query-mode :Complet))
+
+(add-hook *binding-hook* 'init-*query-keys*)
+
+
+(defun query-add-cursor (string)
+ (concatenate 'string (subseq string 0 *query-pos*) "|" (subseq string *query-pos*)))
+
+(defun query-print-string ()
+ (clear-pixmap-buffer *query-window* *query-gc*)
+ (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-foreground*))
+ (xlib:draw-glyphs *pixmap-buffer* *query-gc* 5 (+ (xlib:max-char-ascent *query-font*) 5) *query-message*)
+ (when (< *query-pos* 0)
+ (setf *query-pos* 0))
+ (when (> *query-pos* (length *query-string*))
+ (setf *query-pos* (length *query-string*)))
+ (xlib:draw-glyphs *pixmap-buffer* *query-gc*
+ 10
+ (+ (* 2 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 5)
+ (query-add-cursor (query-show-paren *query-string* *query-pos*)))
+ (copy-pixmap-buffer *query-window* *query-gc*))
+
+
+
+(defun query-enter-function ()
+ (setf *query-font* (xlib:open-font *display* *query-font-string*)
+ *query-window* (xlib:create-window :parent *root*
+ :x 0 :y 0
+ :width (- (xlib:screen-width *screen*) 2)
+ :height (* 3 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*)))
+ :background (get-color *query-background*)
+ :border-width 1
+ :border (get-color *query-border*)
+ :colormap (xlib:screen-default-colormap *screen*)
+ :event-mask '(:exposure :key-press))
+ *query-gc* (xlib:create-gcontext :drawable *query-window*
+ :foreground (get-color *query-foreground*)
+ :background (get-color *query-background*)
+ :font *query-font*
+ :line-style :solid))
+ (xlib:map-window *query-window*)
+ (query-print-string)
+ (wait-no-key-or-button-press))
+
+
+(defun query-leave-function ()
+ (xlib:destroy-window *query-window*)
+ (xlib:close-font *query-font*)
+ (wait-no-key-or-button-press))
+
+(defun query-loop-function ()
+ (raise-window *query-window*))
+
+
+
+(add-hook *binding-hook* 'set-default-query-keys)
+
+(labels ((generic-backspace (del-pos)
+ (when (>= del-pos 0)
+ (setf *query-string* (concatenate 'string
+ (subseq *query-string* 0 del-pos)
+ (subseq *query-string* *query-pos*))
+ *query-pos* del-pos))))
+ (defun query-backspace ()
+ "Delete a character backward"
+ (generic-backspace (1- *query-pos*)))
+
+ (defun query-backspace-word ()
+ "Delete a word backward"
+ (generic-backspace (or (position #\Space *query-string* :from-end t :end *query-pos*) 0))))
+
+
+(labels ((generic-delete (del-pos)
+ (when (<= del-pos (length *query-string*))
+ (setf *query-string* (concatenate 'string
+ (subseq *query-string* 0 *query-pos*)
+ (subseq *query-string* del-pos))))))
+ (defun query-delete ()
+ "Delete a character forward"
+ (generic-delete (1+ *query-pos*)))
+
+ (defun query-delete-word ()
+ "Delete a word forward"
+ (generic-delete (1+ (or (position #\Space *query-string* :start *query-pos*)
+ (1- (length *query-string*)))))))
+
+
+
+(defun query-home ()
+ "Move cursor to line begining"
+ (setf *query-pos* 0))
+
+(defun query-end ()
+ "Move cursor to line end"
+ (setf *query-pos* (length *query-string*)))
+
+
+(defun query-left ()
+ "Move cursor to left"
+ (when (> *query-pos* 0)
+ (setf *query-pos* (1- *query-pos*))))
+
+(defun query-left-word ()
+ "Move cursor to left word"
+ (when (> *query-pos* 0)
+ (setf *query-pos* (let ((p (position #\Space *query-string*
+ :end (min (1- *query-pos*) (length *query-string*))
+ :from-end t)))
+ (if p p 0)))))
+
+(defun query-right ()
+ "Move cursor to right"
+ (when (< *query-pos* (length *query-string*))
+ (setf *query-pos* (1+ *query-pos*))))
+
+(defun query-right-word ()
+ "Move cursor to right word"
+ (when (< *query-pos* (length *query-string*))
+ (setf *query-pos* (let ((p (position #\Space *query-string*
+ :start (min (1+ *query-pos*) (length *query-string*)))))
+ (if p p (length *query-string*))))))
+
+(defun query-previous-history ()
+ "Circulate backward in history"
+ (setf *query-string* (first *query-history*)
+ *query-pos* (length *query-string*)
+ *query-history* (rotate-list *query-history*)))
+
+
+(defun query-next-history ()
+ "Circulate forward in history"
+ (setf *query-string* (first *query-history*)
+ *query-pos* (length *query-string*)
+ *query-history* (anti-rotate-list *query-history*)))
+
+
+
+(defun query-delete-eof ()
+ "Delete the end of the line"
+ (setf *query-string* (subseq *query-string* 0 *query-pos*)))
+
+
+(defun set-default-query-keys ()
+ (define-query-key ("Return") 'leave-query-mode-valid)
+ (define-query-key ("Escape") 'leave-query-mode)
+ (define-query-key ("Tab") 'leave-query-mode-complet)
+ (define-query-key ("BackSpace") 'query-backspace)
+ (define-query-key ("BackSpace" :control) 'query-backspace-word)
+ (define-query-key ("Delete") 'query-delete)
+ (define-query-key ("Delete" :control) 'query-delete-word)
+ (define-query-key ("Home") 'query-home)
+ (define-query-key ("End") 'query-end)
+ (define-query-key ("Left") 'query-left)
+ (define-query-key ("Left" :control) 'query-left-word)
+ (define-query-key ("Right") 'query-right)
+ (define-query-key ("Right" :control) 'query-right-word)
+ (define-query-key ("Up") 'query-previous-history)
+ (define-query-key ("Down") 'query-next-history)
+ (define-query-key ("k" :control) 'query-delete-eof))
+
+
+
+(defun add-in-query-string (code state)
+ (let* ((modifiers (state->modifiers state))
+ (keysym (keycode->keysym code modifiers))
+ (char (xlib:keysym->character *display* keysym)))
+ (when (and (characterp char) (standard-char-p char))
+ (setf *query-string* (concatenate 'string
+ (when (<= *query-pos* (length *query-string*))
+ (subseq *query-string* 0 *query-pos*))
+ (string char)
+ (when (< *query-pos* (length *query-string*))
+ (subseq *query-string* *query-pos*))))
+ (incf *query-pos*))))
+
+
+
+
+(defun query-handle-key (&rest event-slots &key root code state &allow-other-keys)
+ (declare (ignore event-slots root))
+ (unless (funcall-key-from-code *query-keys* code state)
+ (add-in-query-string code state))
+ (query-print-string))
+
+
+
+
+(defun query-string (message &optional (default ""))
+ "Query a string from the keyboard. Display msg as prompt"
+ (let ((grab-keyboard-p (xgrab-keyboard-p))
+ (grab-pointer-p (xgrab-pointer-p)))
+ (setf *query-message* message
+ *query-string* default
+ *query-pos* (length default))
+ (xgrab-pointer *root* 92 93)
+ (unless grab-keyboard-p
+ (ungrab-main-keys)
+ (xgrab-keyboard *root*))
+ (generic-mode 'exit-query-loop
+ :enter-function #'query-enter-function
+ :loop-function #'query-loop-function
+ :leave-function #'query-leave-function
+ :key-press-hook #'query-handle-key)
+ (unless grab-keyboard-p
+ (xungrab-keyboard)
+ (grab-main-keys))
+ (if grab-pointer-p
+ (xgrab-pointer *root* 66 67)
+ (xungrab-pointer)))
+ (when (member *query-return* '(:Return :Complet))
+ (push *query-string* *query-history*))
+ (values *query-string*
+ *query-return*))
Modified: clfswm/src/clfswm-second-mode.lisp
==============================================================================
--- clfswm/src/clfswm-second-mode.lisp (original)
+++ clfswm/src/clfswm-second-mode.lisp Wed Apr 22 16:39:09 2009
@@ -241,7 +241,8 @@
(defun second-key-mode ()
- (generic-mode :enter-function #'sm-enter-function
+ (generic-mode 'exit-second-loop
+ :enter-function #'sm-enter-function
:loop-function #'sm-loop-function
:leave-function #'sm-leave-function
:button-press-hook *sm-button-press-hook*
Modified: clfswm/src/package.lisp
==============================================================================
--- clfswm/src/package.lisp (original)
+++ clfswm/src/package.lisp Wed Apr 22 16:39:09 2009
@@ -157,7 +157,7 @@
(defparameter *second-mouse* nil)
(defparameter *info-keys* nil)
(defparameter *info-mouse* nil)
-
+(defparameter *query-keys* nil)
(defstruct menu name item doc)
More information about the clfswm-cvs
mailing list