[clfswm-cvs] r67 - in clfswm: . src
pbrochard at common-lisp.net
pbrochard at common-lisp.net
Fri Apr 4 20:54:04 UTC 2008
Author: pbrochard
Date: Fri Apr 4 15:53:59 2008
New Revision: 67
Modified:
clfswm/ChangeLog
clfswm/src/bindings-second-mode.lisp
clfswm/src/bindings.lisp
clfswm/src/clfswm-info.lisp
clfswm/src/clfswm-internal.lisp
clfswm/src/clfswm-keys.lisp
clfswm/src/clfswm-second-mode.lisp
clfswm/src/clfswm-util.lisp
clfswm/src/clfswm.lisp
Log:
Allow additional arguments to function on key/mouse press/release. Add keys definitions to bind-or-jump in the second mode.
Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog (original)
+++ clfswm/ChangeLog Fri Apr 4 15:53:59 2008
@@ -1,3 +1,16 @@
+2008-04-04 Philippe Brochard <pbrochard at common-lisp.net>
+
+ * src/bindings-second-mode.lisp: Add keys definitions to
+ bind-or-jump in the second mode.
+
+ * src/clfswm-util.lisp (bind-or-jump): remove the auto-defining
+ macro for bind-or-jump-(1|2|3...).
+
+ * src/clfswm-keys.lisp (define-define-key/mouse): Allow additional
+ arguments to function. This allow to do things like:
+ (define-main-key (key) 'my-function 10 20 'foo) -> 10 20 and 'foo
+ are passed to my-function on key press.
+
2008-04-03 Philippe Brochard <pbrochard at common-lisp.net>
* src/clfswm-util.lisp (bind-or-jump): New (great) function.
Modified: clfswm/src/bindings-second-mode.lisp
==============================================================================
--- clfswm/src/bindings-second-mode.lisp (original)
+++ clfswm/src/bindings-second-mode.lisp Fri Apr 4 15:53:59 2008
@@ -353,6 +353,36 @@
(define-second-key ("Menu" :control) 'toggle-show-root-frame)
+;;; Bind or jump functions
+(define-second-key ("1" :mod-1) 'bind-or-jump 1)
+(define-second-key ("2" :mod-1) 'bind-or-jump 2)
+(define-second-key ("3" :mod-1) 'bind-or-jump 3)
+(define-second-key ("4" :mod-1) 'bind-or-jump 4)
+(define-second-key ("5" :mod-1) 'bind-or-jump 5)
+(define-second-key ("6" :mod-1) 'bind-or-jump 6)
+(define-second-key ("7" :mod-1) 'bind-or-jump 7)
+(define-second-key ("8" :mod-1) 'bind-or-jump 8)
+(define-second-key ("9" :mod-1) 'bind-or-jump 9)
+(define-second-key ("0" :mod-1) 'bind-or-jump 10)
+
+
+;; For an azery keyboard:
+;;(undefine-second-multi-keys (#\1 :mod-1) (#\2 :mod-1) (#\3 :mod-1)
+;; (#\4 :mod-1) (#\5 :mod-1) (#\6 :mod-1)
+;; (#\7 :mod-1) (#\8 :mod-1) (#\9 :mod-1) (#\0 :mod-1))
+;;(define-second-key ("ampersand" :mod-1) 'bind-or-jump 1)
+;;(define-second-key ("eacute" :mod-1) 'bind-or-jump 2)
+;;(define-second-key ("quotedbl" :mod-1) 'bind-or-jump 3)
+;;(define-second-key ("quoteright" :mod-1) 'bind-or-jump 4)
+;;(define-second-key ("parenleft" :mod-1) 'bind-or-jump 5)
+;;(define-second-key ("minus" :mod-1) 'bind-or-jump 6)
+;;(define-second-key ("egrave" :mod-1) 'bind-or-jump 7)
+;;(define-second-key ("underscore" :mod-1) 'bind-or-jump 8)
+;;(define-second-key ("ccedilla" :mod-1) 'bind-or-jump 9)
+;;(define-second-key ("agrave" :mod-1) 'bind-or-jump 10)
+
+
+
Modified: clfswm/src/bindings.lisp
==============================================================================
--- clfswm/src/bindings.lisp (original)
+++ clfswm/src/bindings.lisp Fri Apr 4 15:53:59 2008
@@ -31,7 +31,6 @@
;;;| CONFIG - Bindings main mode
;;;`-----
-
(define-main-key ("F1" :mod-1) 'help-on-clfswm)
(defun quit-clfswm ()
@@ -79,29 +78,32 @@
;;; Bind or jump functions
-(define-main-key ("1" :mod-1) 'bind-or-jump-1)
-(define-main-key ("2" :mod-1) 'bind-or-jump-2)
-(define-main-key ("3" :mod-1) 'bind-or-jump-3)
-(define-main-key ("4" :mod-1) 'bind-or-jump-4)
-(define-main-key ("5" :mod-1) 'bind-or-jump-5)
-(define-main-key ("6" :mod-1) 'bind-or-jump-6)
-(define-main-key ("7" :mod-1) 'bind-or-jump-7)
-(define-main-key ("8" :mod-1) 'bind-or-jump-8)
-(define-main-key ("9" :mod-1) 'bind-or-jump-9)
-(define-main-key ("0" :mod-1) 'bind-or-jump-10)
+(define-main-key ("1" :mod-1) 'bind-or-jump 1)
+(define-main-key ("2" :mod-1) 'bind-or-jump 2)
+(define-main-key ("3" :mod-1) 'bind-or-jump 3)
+(define-main-key ("4" :mod-1) 'bind-or-jump 4)
+(define-main-key ("5" :mod-1) 'bind-or-jump 5)
+(define-main-key ("6" :mod-1) 'bind-or-jump 6)
+(define-main-key ("7" :mod-1) 'bind-or-jump 7)
+(define-main-key ("8" :mod-1) 'bind-or-jump 8)
+(define-main-key ("9" :mod-1) 'bind-or-jump 9)
+(define-main-key ("0" :mod-1) 'bind-or-jump 10)
;; For an azery keyboard:
-;;(define-main-key ("ampersand" :mod-1) 'bind-or-jump-1)
-;;(define-main-key ("eacute" :mod-1) 'bind-or-jump-2)
-;;(define-main-key ("quotedbl" :mod-1) 'bind-or-jump-3)
-;;(define-main-key ("quoteright" :mod-1) 'bind-or-jump-4)
-;;(define-main-key ("parenleft" :mod-1) 'bind-or-jump-5)
-;;(define-main-key ("minus" :mod-1) 'bind-or-jump-6)
-;;(define-main-key ("egrave" :mod-1) 'bind-or-jump-7)
-;;(define-main-key ("underscore" :mod-1) 'bind-or-jump-8)
-;;(define-main-key ("ccedilla" :mod-1) 'bind-or-jump-9)
-;;(define-main-key ("agrave" :mod-1) 'bind-or-jump-10)
+;;(undefine-main-multi-keys (#\1 :mod-1) (#\2 :mod-1) (#\3 :mod-1)
+;; (#\4 :mod-1) (#\5 :mod-1) (#\6 :mod-1)
+;; (#\7 :mod-1) (#\8 :mod-1) (#\9 :mod-1) (#\0 :mod-1))
+;;(define-main-key ("ampersand" :mod-1) 'bind-or-jump 1)
+;;(define-main-key ("eacute" :mod-1) 'bind-or-jump 2)
+;;(define-main-key ("quotedbl" :mod-1) 'bind-or-jump 3)
+;;(define-main-key ("quoteright" :mod-1) 'bind-or-jump 4)
+;;(define-main-key ("parenleft" :mod-1) 'bind-or-jump 5)
+;;(define-main-key ("minus" :mod-1) 'bind-or-jump 6)
+;;(define-main-key ("egrave" :mod-1) 'bind-or-jump 7)
+;;(define-main-key ("underscore" :mod-1) 'bind-or-jump 8)
+;;(define-main-key ("ccedilla" :mod-1) 'bind-or-jump 9)
+;;(define-main-key ("agrave" :mod-1) 'bind-or-jump 10)
@@ -119,8 +121,6 @@
(mouse-focus-move/resize-generic root-x root-y #'resize-frame t))
-
-
(define-main-mouse (1) 'mouse-click-to-focus-and-move)
(define-main-mouse (3) 'mouse-click-to-focus-and-resize)
Modified: clfswm/src/clfswm-info.lisp
==============================================================================
--- clfswm/src/clfswm-info.lisp (original)
+++ clfswm/src/clfswm-info.lisp Fri Apr 4 15:53:59 2008
@@ -237,13 +237,13 @@
(declare (ignore event-slots))
(unless (xlib:event-case (*display* :discard-p nil :peek-p t :timeout 0)
(:motion-notify () t))
- (funcall-button-from-code *info-mouse* 'motion 0 window root-x root-y #'first info)))
+ (funcall-button-from-code *info-mouse* 'motion 0 window root-x root-y *fun-press* (list info))))
(handle-button-press (&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 #'first info))
+ (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 #'third info))
+ (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))
Modified: clfswm/src/clfswm-internal.lisp
==============================================================================
--- clfswm/src/clfswm-internal.lisp (original)
+++ clfswm/src/clfswm-internal.lisp Fri Apr 4 15:53:59 2008
@@ -238,18 +238,6 @@
-
-
-;;(defun get-current-child ()
-;; "Return the current focused child"
-;; (unless (equal *current-child* *root-frame*)
-;; (typecase *current-child*
-;; (xlib:window *current-child*)
-;; (frame (if (xlib:window-p (first (frame-child *current-child*)))
-;; (first (frame-child *current-child*))
-;; *current-child*)))))
-
-
(defun find-child (to-find root)
"Find to-find in root or in its children"
(with-all-children (root child)
Modified: clfswm/src/clfswm-keys.lisp
==============================================================================
--- clfswm/src/clfswm-keys.lisp (original)
+++ clfswm/src/clfswm-keys.lisp Fri Apr 4 15:53:59 2008
@@ -25,6 +25,11 @@
(in-package :clfswm)
+
+(defparameter *fun-press* #'first)
+(defparameter *fun-release* #'second)
+
+
(defun define-hash-table-key-name (hash-table name)
(setf (gethash 'name hash-table) name))
@@ -44,12 +49,12 @@
(undefine-name (create-symbol "undefine-" name "-key"))
(undefine-multi-name (create-symbol "undefine-" name "-multi-keys")))
`(progn
- (defun ,name-key-fun (key function &optional keystring)
+ (defun ,name-key-fun (key function &rest args)
"Define a new key, a key is '(char '(modifier list))"
- (setf (gethash key ,hashtable) (list function keystring)))
+ (setf (gethash key ,hashtable) (list function args)))
- (defmacro ,name-key ((key &rest modifiers) function &optional keystring)
- `(,',name-key-fun (list ,key ,(modifiers->state modifiers)) ,function ,keystring))
+ (defmacro ,name-key ((key &rest modifiers) function &rest args)
+ `(,',name-key-fun (list ,key ,(modifiers->state modifiers)) ,function , at args))
(defmacro ,undefine-name ((key &rest modifiers))
`(remhash (list ,key ,(modifiers->state modifiers)) ,',hashtable))
@@ -65,12 +70,12 @@
(name-mouse (create-symbol "define-" name))
(undefine-name (create-symbol "undefine-" name)))
`(progn
- (defun ,name-mouse-fun (button function-press &optional keystring function-release)
+ (defun ,name-mouse-fun (button function-press &optional function-release &rest args)
"Define a new mouse button action, a button is '(button number '(modifier list))"
- (setf (gethash button ,hashtable) (list function-press keystring function-release)))
+ (setf (gethash button ,hashtable) (list function-press function-release args)))
- (defmacro ,name-mouse ((button &rest modifiers) function-press &optional function-release keystring)
- `(,',name-mouse-fun (list ,button ,(modifiers->state modifiers)) ,function-press ,keystring ,function-release))
+ (defmacro ,name-mouse ((button &rest modifiers) function-press &optional function-release &rest args)
+ `(,',name-mouse-fun (list ,button ,(modifiers->state modifiers)) ,function-press ,function-release , at args))
(defmacro ,undefine-name ((key &rest modifiers))
`(remhash (list ,key ,(modifiers->state modifiers)) ,',hashtable)))))
@@ -133,7 +138,7 @@
(multiple-value-bind (function foundp)
(gethash (list key state) hash-table-key)
(when (and foundp (first function))
- (first function))))
+ function)))
(from-code ()
(function-from code))
(from-char ()
@@ -152,23 +157,19 @@
(defun funcall-key-from-code (hash-table-key code state &rest args)
(let ((function (find-key-from-code hash-table-key code state)))
(when function
- (apply function args)
+ (apply (first function) (append args (second function)))
t)))
-
(defun funcall-button-from-code (hash-table-key code state window root-x root-y
- &optional (action #'first) args)
- "Action: first=press third=release - Return t if a function is found"
+ &optional (action *fun-press*) args)
(let ((state (modifiers->state (set-difference (state->modifiers state)
'(:button-1 :button-2 :button-3 :button-4 :button-5)))))
(multiple-value-bind (function foundp)
(gethash (list code state) hash-table-key)
(if (and foundp (funcall action function))
(progn
- (if args
- (funcall (funcall action function) window root-x root-y args)
- (funcall (funcall action function) window root-x root-y))
+ (apply (funcall action function) `(,window ,root-x ,root-y ,@(append args (third function))))
t)
nil))))
@@ -201,8 +202,7 @@
,(clean-string (format nil "~{~@(~S ~)~}" (state->modifiers (second k)))))
("td align=\"center\" nowrap"
,(clean-string (format nil "~@(~S~)"
- (or (second v)
- (and (stringp (first k))
+ (or (and (stringp (first k))
(intern (string-upcase (first k))))
(first k)))))
("td style=\"color:#0000FF\" nowrap" ,(documentation (or (first v) (third v)) 'function)))
@@ -247,8 +247,7 @@
(when (consp k)
(format stream "~&~20@<~{~@(~A~) ~}~> ~13@<~@(~A~)~> ~A~%"
(state->modifiers (second k))
- (remove #\# (remove #\\ (format nil "~S" (or (second v)
- (and (stringp (first k))
+ (remove #\# (remove #\\ (format nil "~S" (or (and (stringp (first k))
(intern (string-upcase (first k))))
(first k)))))
(documentation (or (first v) (third v)) 'function))))
Modified: clfswm/src/clfswm-second-mode.lisp
==============================================================================
--- clfswm/src/clfswm-second-mode.lisp (original)
+++ clfswm/src/clfswm-second-mode.lisp Fri Apr 4 15:53:59 2008
@@ -80,16 +80,16 @@
(defun sm-handle-motion-notify (&rest event-slots &key root-x root-y &allow-other-keys)
(declare (ignore event-slots))
(unless (compress-motion-notify)
- (funcall-button-from-code *second-mouse* 'motion 0 root-x root-y #'first)))
+ (funcall-button-from-code *second-mouse* 'motion 0 root-x root-y *fun-press*)))
(defun sm-handle-button-press (&rest event-slots &key window root-x root-y code state &allow-other-keys)
(declare (ignore event-slots))
- (funcall-button-from-code *second-mouse* code state window root-x root-y #'first)
+ (funcall-button-from-code *second-mouse* code state window root-x root-y *fun-press*)
(draw-second-mode-window))
(defun sm-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 *second-mouse* code state window root-x root-y #'third)
+ (funcall-button-from-code *second-mouse* code state window root-x root-y *fun-release*)
(draw-second-mode-window))
(defun sm-handle-configure-request (&rest event-slots)
Modified: clfswm/src/clfswm-util.lisp
==============================================================================
--- clfswm/src/clfswm-util.lisp (original)
+++ clfswm/src/clfswm-util.lisp Fri Apr 4 15:53:59 2008
@@ -701,7 +701,7 @@
;;; Bind or jump functions
(let ((key-slots (make-array 10 :initial-element nil))
- (current-slot 0))
+ (current-slot 1))
(defun bind-on-slot ()
"Bind current child to slot"
(setf (aref key-slots current-slot) *current-child*))
@@ -719,6 +719,7 @@
(show-all-children))
(defun bind-or-jump (n)
+ "Bind or jump to a slot"
(let ((default-bind `("Return" bind-on-slot
,(format nil "Bind slot ~A on child: ~A" n (child-fullname *current-child*)))))
(setf current-slot (- n 1))
@@ -732,13 +733,3 @@
(child-fullname it)
"Not set - Please, bind it with Return"))))
(list default-bind))))))
-
-(defmacro def-bind-or-jump ()
- `(progn
- ,@(loop for i from 1 to 10
- collect `(defun ,(intern (format nil "BIND-OR-JUMP-~A" i)) ()
- ,(format nil "Bind or jump to the child on slot ~A" i)
- (bind-or-jump ,i)))))
-
-
-(def-bind-or-jump)
Modified: clfswm/src/clfswm.lisp
==============================================================================
--- clfswm/src/clfswm.lisp (original)
+++ clfswm/src/clfswm.lisp Fri Apr 4 15:53:59 2008
@@ -37,19 +37,19 @@
(defun handle-button-press (&rest event-slots &key code state window root-x root-y &allow-other-keys)
(declare (ignore event-slots))
- (unless (funcall-button-from-code *main-mouse* code state window root-x root-y #'first)
+ (unless (funcall-button-from-code *main-mouse* code state window root-x root-y *fun-press*)
(replay-button-event)))
(defun handle-button-release (&rest event-slots &key code state window root-x root-y &allow-other-keys)
(declare (ignore event-slots))
- (unless (funcall-button-from-code *main-mouse* code state window root-x root-y #'third)
+ (unless (funcall-button-from-code *main-mouse* code state window root-x root-y *fun-release*)
(replay-button-event)))
(defun handle-motion-notify (&rest event-slots &key root-x root-y &allow-other-keys)
(declare (ignore event-slots))
(unless (compress-motion-notify)
- (funcall-button-from-code *main-mouse* 'motion 0 root-x root-y #'first)))
+ (funcall-button-from-code *main-mouse* 'motion 0 root-x root-y *fun-press*)))
(defun handle-configure-request (&rest event-slots &key stack-mode #|parent|# window #|above-sibling|#
More information about the clfswm-cvs
mailing list