Shawn Betts <sabe...@gmail.com> writes:
> There are things in the git repo so I might as well push it out into a
> tarball. Any objections? Any last minute patches people want to throw
> in?
>
I would like to remember the lost patch I sent a time to you include if
you consider appropriate. Greetings.
>From e360f4e604bbeebd77931b39484707e9d566b3b5 Mon Sep 17 00:00:00 2001
From: =?utf-8?q?David=20V=C3=A1zquez?= <dav...@es.gnu.org>
Date: Sat, 13 Feb 2010 00:03:52 +0100
Subject: [PATCH] REQUIRE-MATCH argument for completing-read function.
---
input.lisp | 42 +++++++++++++++++++++++++++++-------------
module.lisp | 11 ++++++-----
2 files changed, 35 insertions(+), 18 deletions(-)
diff --git a/input.lisp b/input.lisp
index b12ae09..c1dc4f0 100644
--- a/input.lisp
+++ b/input.lisp
@@ -180,26 +180,32 @@
(make-array (length initial-input) :element-type 'character :initial-contents initial-input
:adjustable t :fill-pointer t))
-(defun completing-read (screen prompt completions &optional (initial-input ""))
+(defun completing-read (screen prompt completions &optional (initial-input "") require-match)
"Read a line of input through stumpwm and return it with TAB
completion. completions can be a list, an fbound symbol, or a
-function. if its an fbound symbol or a function then that
-function is passed the substring to complete on and is expected
-to return a list of matches."
+function. if its an fbound symbol or a function then that function is
+passed the substring to complete on and is expected to return a list
+of matches. If require-match argument is non-nil then the input must
+match with an element of the completions."
(check-type completions (or list function symbol))
(let ((*input-completions* completions)
(*input-current-completions* nil)
(*input-current-completions-idx* nil))
- (let ((line (read-one-line screen prompt initial-input)))
+ (let ((line (read-one-line screen prompt initial-input require-match)))
(when line (string-trim " " line)))))
-(defun read-one-line (screen prompt &optional (initial-input ""))
+(defun read-one-line (screen prompt &optional (initial-input "") require-match)
"Read a line of input through stumpwm and return it. returns nil if the user aborted."
(let ((*input-last-command* nil)
(input (make-input-line :string (make-input-string initial-input)
:position (length initial-input)
:history -1)))
- (labels ((key-loop ()
+ (labels ((match-input ()
+ (let* ((in (string-trim " " (input-line-string input)))
+ (compls (input-find-completions in *input-completions*)))
+ (and (consp compls)
+ (string= in (car compls)))))
+ (key-loop ()
(loop for key = (read-key-or-selection) do
(cond ((stringp key)
;; handle selection
@@ -208,7 +214,10 @@ to return a list of matches."
;; skip modifiers
((is-modifier (car key)))
((process-input screen prompt input (car key) (cdr key))
- (return (input-line-string input)))))))
+ (if (or (not require-match)
+ (match-input))
+ (return (input-line-string input))
+ (draw-input-bucket screen prompt input "^B^01[No match]" t)))))))
(setup-input-window screen prompt input)
(catch :abort
(unwind-protect
@@ -223,18 +232,19 @@ to return a list of matches."
(keycode->character (car k) (xlib:make-state-keys (cdr k))))))
-(defun draw-input-bucket (screen prompt input &optional errorp)
+(defun draw-input-bucket (screen prompt input &optional (tail "") errorp)
"Draw to the screen's input window the contents of input."
(let* ((gcontext (screen-message-gc screen))
(win (screen-input-window screen))
(prompt-width (xlib:text-width (screen-font screen) prompt :translate #'translate-id))
(string (input-line-string input))
(string-width (xlib:text-width (screen-font screen) string :translate #'translate-id))
- (full-string-width (+ string-width
- (xlib:text-width (screen-font screen) " " :translate #'translate-id)))
+ (space-width (xlib:text-width (screen-font screen) " " :translate #'translate-id))
+ (tail-width (xlib:text-width (screen-font screen) tail :translate #'translate-id))
+ (full-string-width (+ string-width space-width))
(pos (input-line-position input))
(width (+ prompt-width
- (max 100 full-string-width))))
+ (max 100 (+ full-string-width space-width tail-width)))))
(xlib:with-state (win)
(xlib:clear-area win :x (+ *message-window-padding*
prompt-width
@@ -254,6 +264,12 @@ to return a list of matches."
string
:translate #'translate-id
:size 16)
+ (xlib:draw-image-glyphs win gcontext
+ (+ *message-window-padding* prompt-width full-string-width space-width)
+ (xlib:font-ascent (screen-font screen))
+ tail
+ :translate #'translate-id
+ :size 16)
;; draw a block cursor
(invert-rect screen win
(+ *message-window-padding*
@@ -559,7 +575,7 @@ input (pressing Return), nil otherwise."
(throw :abort t))
(:error
;; FIXME draw inverted text
- (draw-input-bucket screen prompt input t)
+ (draw-input-bucket screen prompt input "" t)
nil)
(t
(draw-input-bucket screen prompt input)
diff --git a/module.lisp b/module.lisp
index 9f6d37d..14e348b 100644
--- a/module.lisp
+++ b/module.lisp
@@ -72,7 +72,7 @@
(define-stumpwm-type :module (input prompt)
(or (argument-pop-rest input)
- (completing-read (current-screen) prompt (list-modules))))
+ (completing-read (current-screen) prompt (list-modules) "" t)))
(defun list-modules ()
"Return a list of the available modules."
@@ -90,9 +90,10 @@
"Loads the contributed module with the given NAME."
;; FIXME: This should use ASDF in the future. And maybe there should
;; be an extra stumpwm-contrib repository.
- (let ((module (find-module name)))
- (if module
- (load module)
- (error "No such module: ~a" name))))
+ (when name
+ (let ((module (find-module name)))
+ (when module
+ (load module)))))
+
;; End of file
--
1.5.6.5
_______________________________________________
Stumpwm-devel mailing list
Stumpwm-devel@nongnu.org
http://lists.nongnu.org/mailman/listinfo/stumpwm-devel
