[clfswm-cvs] r373 - in clfswm: . src
Philippe Brochard
pbrochard at common-lisp.net
Sat Oct 30 23:04:23 UTC 2010
Author: pbrochard
Date: Sat Oct 30 19:04:23 2010
New Revision: 373
Log:
src/clfswm-query.lisp (query-mode-complet): New function: Handle completion in query-mode.
Modified:
clfswm/ChangeLog
clfswm/TODO
clfswm/src/clfswm-configuration.lisp
clfswm/src/clfswm-query.lisp
clfswm/src/clfswm-util.lisp
clfswm/src/tools.lisp
Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog (original)
+++ clfswm/ChangeLog Sat Oct 30 19:04:23 2010
@@ -1,3 +1,8 @@
+2010-10-31 Philippe Brochard <pbrochard at common-lisp.net>
+
+ * src/clfswm-query.lisp (query-mode-complet): New function: Handle
+ completion in query-mode.
+
2010-10-30 Philippe Brochard <pbrochard at common-lisp.net>
* src/clfswm-query.lisp (query-print-string): Handle long lines
Modified: clfswm/TODO
==============================================================================
--- clfswm/TODO (original)
+++ clfswm/TODO Sat Oct 30 19:04:23 2010
@@ -7,8 +7,6 @@
===============
Should handle these soon.
-- info mode: complet on [tab] without living the info mode.
-
FOR THE NEXT RELEASE
====================
Modified: clfswm/src/clfswm-configuration.lisp
==============================================================================
--- clfswm/src/clfswm-configuration.lisp (original)
+++ clfswm/src/clfswm-configuration.lisp Sat Oct 30 19:04:23 2010
@@ -141,7 +141,7 @@
(query-string (format nil "Configure ~A" string) original)
(let ((result-val (ignore-errors (eval (read-from-string result))))
(original-val (ignore-errors (eval (read-from-string original)))))
- (if (member return '(:Return :Complet))
+ (if (equal return :Return)
(warn-wrong-type result-val original-val)
original-val)))))
Modified: clfswm/src/clfswm-query.lisp
==============================================================================
--- clfswm/src/clfswm-query.lisp (original)
+++ clfswm/src/clfswm-query.lisp Sat Oct 30 19:04:23 2010
@@ -31,6 +31,7 @@
(defparameter *query-gc* nil)
(defparameter *query-history* nil)
+(defparameter *query-complet-list* nil)
(defparameter *query-message* nil)
(defparameter *query-string* nil)
@@ -91,18 +92,23 @@
(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-find-complet-list ()
+ (remove-if-not (lambda (x)
+ (zerop (or (search *query-string* x :test #'string-equal) -1)))
+ *query-complet-list*))
+
+
(defun query-print-string ()
(let ((dec (min 0 (- (- (xlib:drawable-width *query-window*) 10)
(+ 10 (* *query-pos* (xlib:max-char-width *query-font*)))))))
(clear-pixmap-buffer *query-window* *query-gc*)
(setf (xlib:gcontext-foreground *query-gc*) (get-color *query-message-color*))
- (xlib:draw-glyphs *pixmap-buffer* *query-gc* 5 (+ (xlib:max-char-ascent *query-font*) 5) *query-message*)
+ (xlib:draw-glyphs *pixmap-buffer* *query-gc* 5 (+ (xlib:max-char-ascent *query-font*) 5)
+ (format nil "~A ~{~A~^, ~}" *query-message*
+ (query-find-complet-list)))
(when (< *query-pos* 0)
(setf *query-pos* 0))
(when (> *query-pos* (length *query-string*))
@@ -243,13 +249,22 @@
(setf *query-string* (subseq *query-string* 0 *query-pos*)))
+(defun query-mode-complet ()
+ (setf *query-string* (find-common-string *query-string* (query-find-complet-list)))
+ (let ((complet (query-find-complet-list)))
+ (when (= (length complet) 1)
+ (setf *query-string* (first complet))))
+ (query-end))
+
+
+
(add-hook *binding-hook* 'set-default-query-keys)
(defun set-default-query-keys ()
(define-query-key ("Return") 'leave-query-mode-valid)
(define-query-key ("Escape") 'leave-query-mode)
(define-query-key ("g" :control) 'leave-query-mode)
- (define-query-key ("Tab") 'leave-query-mode-complet)
+ (define-query-key ("Tab") 'query-mode-complet)
(define-query-key ("BackSpace") 'query-backspace)
(define-query-key ("BackSpace" :control) 'query-backspace-word)
(define-query-key ("Delete") 'query-delete)
@@ -288,13 +303,14 @@
-(defun query-string (message &optional (default ""))
+(defun query-string (message &optional (default "") complet-list)
"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))
+ *query-pos* (length default)
+ *query-complet-list* complet-list)
(xgrab-pointer *root* 92 93)
(unless grab-keyboard-p
(ungrab-main-keys)
@@ -310,7 +326,7 @@
(if grab-pointer-p
(xgrab-pointer *root* 66 67)
(xungrab-pointer)))
- (when (member *query-return* '(:Return :Complet))
+ (when (equal *query-return* :Return)
(pushnew default *query-history* :test #'equal)
(push *query-string* *query-history*))
(values *query-string*
Modified: clfswm/src/clfswm-util.lisp
==============================================================================
--- clfswm/src/clfswm-util.lisp (original)
+++ clfswm/src/clfswm-util.lisp Sat Oct 30 19:04:23 2010
@@ -364,27 +364,10 @@
;;; Frame name actions
(defun ask-frame-name (msg)
"Ask a frame name"
- (let ((all-frame-name nil)
- (name ""))
+ (let ((all-frame-name nil))
(with-all-frames (*root-frame* frame)
(awhen (frame-name frame) (push it all-frame-name)))
- (labels ((selected-names ()
- (loop :for str :in all-frame-name
- :when (zerop (or (search name str :test #'string-equal) -1))
- :collect str))
- (complet-alone (req sel)
- (if (= 1 (length sel)) (first sel) req))
- (ask ()
- (let* ((selected (selected-names))
- (default (complet-alone name selected)))
- (multiple-value-bind (str done)
- (query-string (format nil "~A: ~{~A~^, ~}" msg selected) default)
- (setf name str)
- (when (or (not (string-equal name default)) (eql done :complet))
- (ask))))))
- (ask))
- name))
-
+ (query-string msg "" all-frame-name)))
;;; Focus by functions
@@ -399,7 +382,7 @@
(defun focus-frame-by-name ()
"Focus a frame by name"
- (focus-frame-by (find-frame-by-name (ask-frame-name "Focus frame")))
+ (focus-frame-by (find-frame-by-name (ask-frame-name "Focus frame:")))
(leave-second-mode))
(defun focus-frame-by-number ()
@@ -418,7 +401,7 @@
(defun open-frame-by-name ()
"Open a new frame in a named frame"
- (open-frame-by (find-frame-by-name (ask-frame-name "Open a new frame in")))
+ (open-frame-by (find-frame-by-name (ask-frame-name "Open a new frame in: ")))
(leave-second-mode))
(defun open-frame-by-number ()
@@ -441,7 +424,7 @@
(defun delete-frame-by-name ()
"Delete a frame by name"
- (delete-frame-by (find-frame-by-name (ask-frame-name "Delete frame")))
+ (delete-frame-by (find-frame-by-name (ask-frame-name "Delete frame: ")))
(leave-second-mode))
(defun delete-frame-by-number ()
@@ -463,7 +446,7 @@
"Move current child in a named frame"
(move-child-to *current-child*
(find-frame-by-name
- (ask-frame-name (format nil "Move '~A' to frame" (child-name *current-child*)))))
+ (ask-frame-name (format nil "Move '~A' to frame: " (child-name *current-child*)))))
(leave-second-mode))
(defun move-current-child-by-number ()
@@ -486,7 +469,7 @@
"Copy current child in a named frame"
(copy-child-to *current-child*
(find-frame-by-name
- (ask-frame-name (format nil "Copy '~A' to frame" (child-name *current-child*)))))
+ (ask-frame-name (format nil "Copy '~A' to frame: " (child-name *current-child*)))))
(leave-second-mode))
(defun copy-current-child-by-number ()
Modified: clfswm/src/tools.lisp
==============================================================================
--- clfswm/src/tools.lisp (original)
+++ clfswm/src/tools.lisp Sat Oct 30 19:04:23 2010
@@ -54,6 +54,7 @@
:export-all-functions-and-variables
:ensure-function
:empty-string-p
+ :find-common-string
:is-config-p :config-documentation :config-group
:setf/=
:create-symbol
@@ -355,6 +356,20 @@
(string= string ""))
+(defun find-common-string (string list &optional orig)
+ "Return the string in common in all string in list"
+ (if list
+ (let ((result (remove-if-not (lambda (x)
+ (zerop (or (search string x :test #'string-equal) -1)))
+ list)))
+ (if (= (length result) (length list))
+ (if (> (length (first list)) (length string))
+ (find-common-string (subseq (first list) 0 (1+ (length string))) list string)
+ string)
+ orig))
+ string))
+
+
;;; Auto configuration tools
;;; Syntaxe: (defparameter symbol value "Config(config group): documentation string")
More information about the clfswm-cvs
mailing list