[STUMP] Patch

[Manuel Giraud]

Hi,

This patch compiles an old one plus other features:
   - Cursor in the input window;
   - Cleaner (but not so clean) input window's keybindings;
   - Bug correction in the sample-stumpwmrc;
   - Remove dumb message when renumbering.

---8<-------------------------------------------
Index: core.lisp
===================================================================
RCS file: /cvsroot/stumpwm/stumpwm/core.lisp,v
retrieving revision 1.9
diff -u -r1.9 core.lisp
--- core.lisp   1 Dec 2004 01:18:20 -0000       1.9
+++ core.lisp   14 Dec 2004 17:59:32 -0000
@@ -363,6 +363,14 @@
                        :background
                        (xlib:screen-black-pixel (screen-number screen))))
 
+(defun create-cursor-gcontext (screen)
+  (xlib:create-gcontext :drawable (screen-message-window screen)
+                       :font (screen-font screen)
+                       :foreground
+                       (xlib:screen-white-pixel (screen-number screen))
+                       :background 
+                       (xlib:alloc-color (xlib:screen-default-colormap 
(screen-number screen)) *cursor-color*)))
+
 (defun max-width (font l)
   "Return the width of the longest string in L using FONT."
   (loop for i in l
Index: input.lisp
===================================================================
RCS file: /cvsroot/stumpwm/stumpwm/input.lisp,v
retrieving revision 1.5
diff -u -r1.5 input.lisp
--- input.lisp  1 Dec 2004 01:18:20 -0000       1.5
+++ input.lisp  14 Dec 2004 17:59:32 -0000
@@ -75,8 +75,9 @@
 
 (defun read-one-line (screen prompt &optional (initial-input ""))
   "Read a line of input through stumpwm and return it."
-  (labels ((key-loop ()
-            (let ((input (coerce initial-input 'list)))
+  (let* ((content (coerce initial-input 'list))
+        (input (make-buffer :content content :index (length content))))
+    (labels ((key-loop ()
               (do ((key (read-key) (read-key)))
                   (nil)
                 (multiple-value-bind (inp ret) (process-input screen prompt 
input
@@ -86,13 +87,13 @@
                     ('done
                      (return (values input 'done)))
                     ('abort
-                     (return (values input 'abort)))))))))
-    (setup-input-window screen prompt initial-input)
-    (multiple-value-bind (input ret) (key-loop)
-      (shutdown-input-window screen)
-      (unless (eq ret 'abort)
-       ;; Return the input bucket as a string
-       (concatenate 'string input)))))
+                     (return (values input 'abort))))))))
+      (setup-input-window screen prompt input)
+      (multiple-value-bind (input ret) (key-loop)
+       (shutdown-input-window screen)
+       (unless (eq ret 'abort)
+         ;; Return the input bucket as a string
+         (concatenate 'string (buffer-content input)))))))
 
 (defun read-one-char (screen)
   "Read a single character."
@@ -106,14 +107,22 @@
 (defun draw-input-bucket (screen prompt input)
   "Draw to the screen's input window the contents of input."
   (let* ((gcontext (create-message-window-gcontext screen))
+        (cursor-gcontext (create-cursor-gcontext screen))
         (win (screen-input-window screen))
         (prompt-width (xlib:text-width (screen-font screen) prompt))
+        (content (buffer-content input))
+        (index (buffer-index input))
+        (before-chunk (subseq content 0 index))
+        (cursor-chunk (subseq content index (min (length content) (1+ index))))
+        (after-chunk (subseq content (min (length content) (1+ index))))
+        (before-width (xlib:text-width (screen-font screen) before-chunk))
+        (cursor-width (xlib:text-width (screen-font screen) cursor-chunk))
         (width (+ prompt-width
-                  (max 100 (xlib:text-width (screen-font screen) input))))
-       (screen-width (xlib:drawable-width (xlib:screen-root (screen-number 
screen)))))
+                  (max 100 (xlib:text-width (screen-font screen) content))))
+        (screen-width (xlib:drawable-width (xlib:screen-root (screen-number 
screen)))))
     (xlib:clear-area win :x (+ *message-window-padding*
                               prompt-width
-                              (xlib:text-width (screen-font screen) input)))
+                              (xlib:text-width (screen-font screen) content)))
     (xlib:with-state (win)
                     (setf (xlib:drawable-x win) (- screen-width width
                                                    (* 
(xlib:drawable-border-width win) 2)
@@ -123,10 +132,79 @@
                            *message-window-padding*
                            (xlib:font-ascent (screen-font screen))
                            prompt)
+    ;; Before cursor
     (xlib:draw-image-glyphs win gcontext
                            (+ *message-window-padding* prompt-width)
                            (xlib:font-ascent (screen-font screen))
-                           input)))
+                           before-chunk)
+    ;; Cursor
+    (xlib:draw-image-glyphs win cursor-gcontext
+                           (+ *message-window-padding* prompt-width 
before-width)
+                           (xlib:font-ascent (screen-font screen))
+                           (or cursor-chunk " "))
+    ;; After cursor
+    (xlib:draw-image-glyphs win gcontext
+                           (+ *message-window-padding* prompt-width 
before-width cursor-width)
+                           (xlib:font-ascent (screen-font screen))
+                           after-chunk)))
+
+
+;; Simple buffer with index management
+(defstruct buffer content index)
+
+(defun goto-end (buffer)
+  "Set index to the end of buffer."
+  (setf (buffer-index buffer) (length (buffer-content buffer))))
+
+(defun goto-start (buffer)
+  "Set index to the beginning of buffer."
+  (setf (buffer-index buffer) 0))
+
+(defun move-left (buffer)
+  "Move left :-)"
+  (setf (buffer-index buffer) (max 0 (1- (buffer-index buffer)))))
+
+(defun move-right (buffer)
+  "Move right :-)"
+  (setf (buffer-index buffer) (min (length (buffer-content buffer)) (1+ 
(buffer-index buffer)))))
+
+(defun insert-and-move (buffer obj)
+  "Insert obj and increment index."
+  (setf (buffer-content buffer)
+       (concatenate 'list 
+                    (subseq (buffer-content buffer) 0 (buffer-index buffer)) 
+                    (list obj)
+                    (subseq (buffer-content buffer) (buffer-index buffer))))
+  (incf (buffer-index buffer)))
+
+(defun deinsert-and-move (buffer)
+  "Remove one object of buffer and decrement index."
+  (setf (buffer-content buffer)
+       (concatenate 'list 
+                    (subseq (buffer-content buffer) 0 (max 0 (1- (buffer-index 
buffer))))
+                    (subseq (buffer-content buffer) (buffer-index buffer))))
+  (setf (buffer-index buffer) (max 0 (1- (buffer-index buffer)))))
+
+(defun deinsert-forward (buffer)
+  (setf (buffer-content buffer)
+       (concatenate 'list 
+                    (subseq (buffer-content buffer) 0 (buffer-index buffer))
+                    (subseq (buffer-content buffer) (1+ (buffer-index 
buffer))))))
+
+;; XXX Might be merge with 'set-key-binding' and hash table as an argument.
+(defun set-input-key-binding (key mod cmd)
+  "Bind KEY to the function FN."
+  (setf (gethash (list key mod) *input-key-bindings*) cmd))
+
+(defun set-default-input-bindings ()
+  (set-input-key-binding #\Return '() #'(lambda (inp) (values inp 'done)))
+  (set-input-key-binding #\Backspace '() #'(lambda (inp) (deinsert-and-move 
inp) (values inp nil)))
+  (set-input-key-binding #\g '(:control) #'(lambda (inp) (values inp 'abort)))
+  (set-input-key-binding #\a '(:control) #'(lambda (inp) (goto-start inp) 
(values inp nil)))
+  (set-input-key-binding #\e '(:control) #'(lambda (inp) (goto-end inp) 
(values inp nil)))
+  (set-input-key-binding #\b '(:control) #'(lambda (inp) (move-left inp) 
(values inp nil)))
+  (set-input-key-binding #\f '(:control) #'(lambda (inp) (move-right inp) 
(values inp nil)))
+  (set-input-key-binding #\d '(:control) #'(lambda (inp) (deinsert-forward 
inp) (values inp nil))))
 
 (defun process-input (screen prompt input code state)
   "Process the key (code and state), given the current input
@@ -135,24 +213,15 @@
              "Call the appropriate function based on the key
 pressed. Return 'done when the use has signalled the finish of his
 input (pressing Return), nil otherwise."
-             (cond ((eq (xlib:keycode->keysym *display* code 0)
-                        (char->keysym #\Return))
-                    (values inp 'done))
-                   ((eq (xlib:keycode->keysym *display* code 0)
-                        (char->keysym #\Backspace))
-                    (if (cdr inp)
-                        (rplacd (last inp 2) '())
-                      (setf inp nil))
-                    (values inp nil))
-                   ((and (eq (xlib:keycode->keysym *display* code 0)
-                             (char->keysym #\g))
-                         (member :control (xlib:make-state-keys state)))
-                    (values inp 'abort))
-                   (t (let* ((mods (xlib:make-state-keys state))
-                             (ch (keycode->character code mods)))
-                        (if (and (characterp ch) (char>= ch #\Space) (char<= 
ch #\~))
-                            (setf inp (conc1 inp ch)))
-                        (values inp nil))))))
+             (let* ((mods (xlib:make-state-keys state))
+                    (ch (keycode->character code mods)))
+               (multiple-value-bind (fn present-p) (gethash (list ch mods) 
*input-key-bindings*)
+                 (if present-p
+                     (funcall fn inp)
+                   (progn
+                     (when (and (characterp ch) (char>= ch #\Space) (char<= ch 
#\~))
+                       (insert-and-move inp ch))
+                     (values inp nil)))))))
     (multiple-value-bind (inp ret) (process-key input code state)
       (case ret
        ('done
Index: primitives.lisp
===================================================================
RCS file: /cvsroot/stumpwm/stumpwm/primitives.lisp,v
retrieving revision 1.6
diff -u -r1.6 primitives.lisp
--- primitives.lisp     1 Dec 2004 01:18:20 -0000       1.6
+++ primitives.lisp     14 Dec 2004 17:59:32 -0000
@@ -75,6 +75,9 @@
 (defvar *font-name* "9x15bold"
   "The name of the font to use when stumpwm displays messages.")
 
+(defvar *cursor-color* "blue"
+  "Input window cursor color.")
+
 (defvar *prefix-key* #\t
   "The key to use as the prefix key")
 
@@ -97,6 +100,8 @@
 (defvar *key-bindings* (make-hash-table :test 'equal)
   "An alist of keysym function pairs.")
 
+(defvar *input-key-bindings* (make-hash-table :test 'equal))
+
 ;; FIXME: This variable is set only once but it needs to be set after
 ;; the display is opened. So should it have +'s around it even though
 ;; it's defined as a variable?
Index: sample-stumpwmrc.lisp
===================================================================
RCS file: /cvsroot/stumpwm/stumpwm/sample-stumpwmrc.lisp,v
retrieving revision 1.3
diff -u -r1.3 sample-stumpwmrc.lisp
--- sample-stumpwmrc.lisp       1 Dec 2004 01:39:27 -0000       1.3
+++ sample-stumpwmrc.lisp       14 Dec 2004 17:59:32 -0000
@@ -24,8 +24,8 @@
 (defmacro make-web-jump (name prefix)
   `(define-stumpwm-command ,name (screen (search :rest ,(concatenate 'string 
name " search: ")))
      (declare (ignorable screen))
-     (substitute #\+ #\Space search)
-     (run-shell-command (concatenate 'string ,prefix search))))
+     (let ((search (substitute #\+ #\Space search)))
+       (run-shell-command (concatenate 'string ,prefix search)))))
 
 (make-web-jump "google" "firefox http://www.google.fr/search?q=";)
 (make-web-jump "imdb" "firefox http://www.imdb.com/find?q=";)
Index: stumpwm.lisp
===================================================================
RCS file: /cvsroot/stumpwm/stumpwm/stumpwm.lisp,v
retrieving revision 1.22
diff -u -r1.22 stumpwm.lisp
--- stumpwm.lisp        1 Dec 2004 01:18:20 -0000       1.22
+++ stumpwm.lisp        14 Dec 2004 17:59:32 -0000
@@ -110,6 +110,7 @@
        (focus-frame (first *screen-list*) (screen-current-frame (first 
*screen-list*)))
        ;; Setup the default key bindings. FIXME: should this be in the hook?
        (set-default-bindings)
+       (set-default-input-bindings)
        (echo-string (first *screen-list*) "Welcome to The Stump Window 
Manager!")
        ;; Load rc file
        (multiple-value-bind (success err rc) (load-rc-file)
Index: user.lisp
===================================================================
RCS file: /cvsroot/stumpwm/stumpwm/user.lisp,v
retrieving revision 1.11
diff -u -r1.11 user.lisp
--- user.lisp   1 Dec 2004 03:49:56 -0000       1.11
+++ user.lisp   14 Dec 2004 17:59:32 -0000
@@ -375,8 +375,7 @@
          (setf (window-number screen win) nf)
          (setf (window-number screen (screen-current-window screen)) nt))
       ;; Just give the window the number
-      (setf (window-number screen (screen-current-window screen)) nt)))
-  (echo-string screen "Number expected"))
+      (setf (window-number screen (screen-current-window screen)) nt))))
 
 (define-stumpwm-command "number" (screen (n :number "Number: "))
   (renumber screen n))
---8<-------------------------------------------

-- 
Manuel Giraud (CNRS/CETP)