[clfswm-cvs] r207 - in clfswm: . src
Philippe Brochard
pbrochard at common-lisp.net
Sat Apr 18 20:54:05 UTC 2009
Author: pbrochard
Date: Sat Apr 18 16:54:05 2009
New Revision: 207
Log:
Add a generic mode to define all other modes.
Modified:
clfswm/ChangeLog
clfswm/clfswm.asd
clfswm/src/clfswm-internal.lisp
clfswm/src/clfswm-second-mode.lisp
clfswm/src/package.lisp
clfswm/src/tools.lisp
Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog (original)
+++ clfswm/ChangeLog Sat Apr 18 16:54:05 2009
@@ -1,3 +1,8 @@
+2009-04-18 Xavier Maillard <xma at gnu.org>
+
+ * src/clfswm-generic-mode.lisp (generic-mode): Add a generic mode
+ to define all other modes.
+
2009-04-05 Philippe Brochard <pbrochard at common-lisp.net>
* src/package.lisp (): Use *default-font-string* for all
Modified: clfswm/clfswm.asd
==============================================================================
--- clfswm/clfswm.asd (original)
+++ clfswm/clfswm.asd Sat Apr 18 16:54:05 2009
@@ -29,6 +29,8 @@
:depends-on ("package" "config" "xlib-util" "keysyms"))
(:file "clfswm-autodoc"
:depends-on ("package" "clfswm-keys" "my-html" "tools" "config"))
+ (:file "clfswm-generic-mode"
+ :depends-on ("package" "tools"))
(:file "clfswm-internal"
:depends-on ("xlib-util" "clfswm-keys" "netwm-util" "tools" "config"))
(:file "clfswm"
@@ -37,7 +39,7 @@
(:file "version"
:depends-on ("tools"))
(:file "clfswm-second-mode"
- :depends-on ("package" "clfswm" "clfswm-internal"))
+ :depends-on ("package" "clfswm" "clfswm-internal" "clfswm-generic-mode"))
(:file "clfswm-corner"
:depends-on ("package" "config" "clfswm-internal"))
(:file "clfswm-info"
Modified: clfswm/src/clfswm-internal.lisp
==============================================================================
--- clfswm/src/clfswm-internal.lisp (original)
+++ clfswm/src/clfswm-internal.lisp Sat Apr 18 16:54:05 2009
@@ -760,16 +760,16 @@
(reorder ()
(let ((elem (nth (mod (incf hit direction) (length orig)) orig)))
(funcall set-fun (nconc (list elem) (remove elem orig)))))
- (handle-key-press (&rest event-slots &key root code state &allow-other-keys)
+ (handle-key-press (&rest event-slots &key code state &allow-other-keys)
(declare (ignore event-slots))
- (dbg 'press root code state)
- (dbg (first reverse-modifiers) (state->modifiers state))
+ ;;(dbg 'press root code state)
+ ;;(dbg (first reverse-modifiers) (state->modifiers state))
(if (is-reverse-modifier code state)
(setf direction -1)
(reorder)))
- (handle-key-release (&rest event-slots &key root code state &allow-other-keys)
+ (handle-key-release (&rest event-slots &key code state &allow-other-keys)
(declare (ignore event-slots))
- (dbg 'release root code state)
+ ;;(dbg 'release root code state)
(when (is-reverse-modifier code state)
(setf direction 1))
(when (member code modifier)
@@ -789,8 +789,7 @@
(xlib:display-finish-output *display*)
(xlib:process-event *display* :handler #'handle-select-next-child-event)))
(xungrab-keyboard)
- (grab-main-keys)
- (print 'fin-du-tab)))))
+ (grab-main-keys)))))
(defun set-select-next-child (new)
(setf (frame-child *current-child*) new)
Modified: clfswm/src/clfswm-second-mode.lisp
==============================================================================
--- clfswm/src/clfswm-second-mode.lisp (original)
+++ clfswm/src/clfswm-second-mode.lisp Sat Apr 18 16:54:05 2009
@@ -125,33 +125,78 @@
-(defun sm-handle-event (&rest event-slots &key display event-key &allow-other-keys)
- (declare (ignore display))
- ;; (dbg event-key)
- (with-xlib-protect
- (case event-key
- (:button-press (call-hook *sm-button-press-hook* event-slots))
- (:button-release (call-hook *sm-button-release-hook* event-slots))
- (:motion-notify (call-hook *sm-motion-notify-hook* event-slots))
- (:key-press (call-hook *sm-key-press-hook* event-slots))
- (:configure-request (call-hook *sm-configure-request-hook* event-slots))
- (:configure-notify (call-hook *sm-configure-notify-hook* event-slots))
- (:map-request (call-hook *sm-map-request-hook* event-slots))
- (:unmap-notify (call-hook *sm-unmap-notify-hook* event-slots))
- (:destroy-notify (call-hook *sm-destroy-notify-hook* event-slots))
- (:mapping-notify (call-hook *sm-mapping-notify-hook* event-slots))
- (:property-notify (call-hook *sm-property-notify-hook* event-slots))
- (:create-notify (call-hook *sm-create-notify-hook* event-slots))
- (:enter-notify (call-hook *sm-enter-notify-hook* event-slots))
- (:exposure (call-hook *sm-exposure-hook* event-slots))))
- ;;(dbg "Ignore handle event" c event-slots)))
- t)
+;;(defun sm-handle-event (&rest event-slots &key display event-key &allow-other-keys)
+;; (declare (ignore display))
+;; ;; (dbg event-key)
+;; (with-xlib-protect
+;; (case event-key
+;; (:button-press (call-hook *sm-button-press-hook* event-slots))
+;; (:button-release (call-hook *sm-button-release-hook* event-slots))
+;; (:motion-notify (call-hook *sm-motion-notify-hook* event-slots))
+;; (:key-press (call-hook *sm-key-press-hook* event-slots))
+;; (:configure-request (call-hook *sm-configure-request-hook* event-slots))
+;; (:configure-notify (call-hook *sm-configure-notify-hook* event-slots))
+;; (:map-request (call-hook *sm-map-request-hook* event-slots))
+;; (:unmap-notify (call-hook *sm-unmap-notify-hook* event-slots))
+;; (:destroy-notify (call-hook *sm-destroy-notify-hook* event-slots))
+;; (:mapping-notify (call-hook *sm-mapping-notify-hook* event-slots))
+;; (:property-notify (call-hook *sm-property-notify-hook* event-slots))
+;; (:create-notify (call-hook *sm-create-notify-hook* event-slots))
+;; (:enter-notify (call-hook *sm-enter-notify-hook* event-slots))
+;; (:exposure (call-hook *sm-exposure-hook* event-slots))))
+;; ;;(dbg "Ignore handle event" c event-slots)))
+;; t)
+
+
+
+;;(defun second-key-mode ()
+;; "Switch to editing mode"
+;; ;;(dbg "Second key ignore" c)))))
+;; (setf *in-second-mode* t
+;; *sm-window* (xlib:create-window :parent *root*
+;; :x (truncate (/ (- (xlib:screen-width *screen*) *sm-width*) 2))
+;; :y 0
+;; :width *sm-width* :height *sm-height*
+;; :background (get-color *sm-background-color*)
+;; :border-width 1
+;; :border (get-color *sm-border-color*)
+;; :colormap (xlib:screen-default-colormap *screen*)
+;; :event-mask '(:exposure))
+;; *sm-font* (xlib:open-font *display* *sm-font-string*)
+;; *sm-gc* (xlib:create-gcontext :drawable *sm-window*
+;; :foreground (get-color *sm-foreground-color*)
+;; :background (get-color *sm-background-color*)
+;; :font *sm-font*
+;; :line-style :solid))
+;; (xlib:map-window *sm-window*)
+;; (draw-second-mode-window)
+;; (no-focus)
+;; (ungrab-main-keys)
+;; (xgrab-keyboard *root*)
+;; (xgrab-pointer *root* 66 67)
+;; (unwind-protect
+;; (catch 'exit-second-loop
+;; (loop
+;; (raise-window *sm-window*)
+;; (xlib:display-finish-output *display*)
+;; (xlib:process-event *display* :handler #'sm-handle-event)
+;; (xlib:display-finish-output *display*)))
+;; (xlib:free-gcontext *sm-gc*)
+;; (xlib:close-font *sm-font*)
+;; (xlib:destroy-window *sm-window*)
+;; (xungrab-keyboard)
+;; (xungrab-pointer)
+;; (grab-main-keys)
+;; (show-all-children)
+;; (display-all-frame-info))
+;; (wait-no-key-or-button-press)
+;; (when *second-mode-program*
+;; (do-shell *second-mode-program*)
+;; (setf *second-mode-program* nil))
+;; (setf *in-second-mode* nil))
-
-(defun second-key-mode ()
- "Switch to editing mode"
- ;;(dbg "Second key ignore" c)))))
+(defun sm-enter-function ()
(setf *in-second-mode* t
*sm-window* (xlib:create-window :parent *root*
:x (truncate (/ (- (xlib:screen-width *screen*) *sm-width*) 2))
@@ -173,22 +218,20 @@
(no-focus)
(ungrab-main-keys)
(xgrab-keyboard *root*)
- (xgrab-pointer *root* 66 67)
- (unwind-protect
- (catch 'exit-second-loop
- (loop
- (raise-window *sm-window*)
- (xlib:display-finish-output *display*)
- (xlib:process-event *display* :handler #'sm-handle-event)
- (xlib:display-finish-output *display*)))
- (xlib:free-gcontext *sm-gc*)
- (xlib:close-font *sm-font*)
- (xlib:destroy-window *sm-window*)
- (xungrab-keyboard)
- (xungrab-pointer)
- (grab-main-keys)
- (show-all-children)
- (display-all-frame-info))
+ (xgrab-pointer *root* 66 67))
+
+(defun sm-loop-function ()
+ (raise-window *sm-window*))
+
+(defun sm-leave-function ()
+ (xlib:free-gcontext *sm-gc*)
+ (xlib:close-font *sm-font*)
+ (xlib:destroy-window *sm-window*)
+ (xungrab-keyboard)
+ (xungrab-pointer)
+ (grab-main-keys)
+ (show-all-children)
+ (display-all-frame-info)
(wait-no-key-or-button-press)
(when *second-mode-program*
(do-shell *second-mode-program*)
@@ -196,6 +239,26 @@
(setf *in-second-mode* nil))
+(defun second-key-mode ()
+ (generic-mode :enter-function #'sm-enter-function
+ :loop-function #'sm-loop-function
+ :leave-function #'sm-leave-function
+ :button-press-hook *sm-button-press-hook*
+ :button-release-hook *sm-button-release-hook*
+ :key-press-hook *sm-key-press-hook*
+ :key-release-hook *sm-key-release-hook*
+ :motion-notify-hook *sm-motion-notify-hook*
+ :configure-request-hook *sm-configure-request-hook*
+ :configure-notify-hook *sm-configure-notify-hook*
+ :map-request-hook *sm-map-request-hook*
+ :unmap-notify-hook *sm-unmap-notify-hook*
+ :destroy-notify-hook *sm-destroy-notify-hook*
+ :mapping-notify-hook *sm-mapping-notify-hook*
+ :property-notify-hook *sm-property-notify-hook*
+ :create-notify-hook *sm-create-notify-hook*
+ :enter-notify-hook *sm-enter-notify-hook*
+ :exposure-hook *sm-exposure-hook*))
+
(defun leave-second-mode ()
"Leave second mode"
Modified: clfswm/src/package.lisp
==============================================================================
--- clfswm/src/package.lisp (original)
+++ clfswm/src/package.lisp Sat Apr 18 16:54:05 2009
@@ -175,6 +175,8 @@
"Config(Hook group):")
(defparameter *key-press-hook* nil
"Config(Hook group):")
+(defparameter *key-release-hook* nil
+ "Config(Hook group):")
(defparameter *configure-request-hook* nil
"Config(Hook group):")
(defparameter *configure-notify-hook* nil
@@ -206,6 +208,8 @@
"Config(Hook group):")
(defparameter *sm-key-press-hook* nil
"Config(Hook group):")
+(defparameter *sm-key-release-hook* nil
+ "Config(Hook group):")
(defparameter *sm-configure-request-hook* nil
"Config(Hook group):")
(defparameter *sm-configure-notify-hook* nil
Modified: clfswm/src/tools.lisp
==============================================================================
--- clfswm/src/tools.lisp (original)
+++ clfswm/src/tools.lisp Sat Apr 18 16:54:05 2009
@@ -31,6 +31,7 @@
(:export :it
:awhen
:aif
+ :nfuncall
:call-hook
:add-hook
:remove-hook
@@ -90,7 +91,7 @@
:subst-strings
:test-find-string))
-
+
(in-package :tools)
@@ -108,6 +109,10 @@
(defmacro aif (test then &optional else)
`(let ((it ,test)) (if it ,then ,else)))
+(defun nfuncall (function)
+ (when function
+ (funcall function)))
+
;;;,-----
;;;| Minimal hook
@@ -198,7 +203,7 @@
(when verbose
(format t "Exporting ~S~%" symbol))
(export symbol package))))
-
+
(defun export-all-variables (package &optional (verbose nil))
(with-all-internal-symbols (symbol package)
@@ -242,7 +247,7 @@
(= (or (search start-string doc :test #'string-equal) -1) 0)
(search stop-string doc)
t))))
-
+
(defun config-documentation (symbol)
(when (is-config-p symbol)
(let ((doc (documentation symbol 'variable)))
@@ -348,7 +353,7 @@
(pos-2 (position delim line :start (1+ (or pos-1 0)))))
(when (and pos pos-1 pos-2)
(subseq line (1+ pos-1) pos-2))))
-
+
(defun print-space (n &optional (stream *standard-output*))
"Print n spaces on stream"
@@ -414,15 +419,15 @@
:stream :wait wt)))
(unless proc
(error "Cannot create process."))
- (make-two-way-stream
- (sb-ext:process-output proc)
+ (make-two-way-stream
+ (sb-ext:process-output proc)
(sb-ext:process-input proc)))
#+:lispworks (system:open-pipe fullstring :direction :io)
#+:allegro (let ((proc (excl:run-shell-command
(apply #'vector program program args)
:input :stream :output :stream :wait wt)))
(unless proc
- (error "Cannot create process."))
+ (error "Cannot create process."))
proc)
#+:ecl(ext:run-program program args :input :stream :output :stream
:error :output)
@@ -493,8 +498,8 @@
#+gcl (lisp:quit)
#+lispworks (lw:quit)
#+(or allegro-cl allegro-cl-trial) (excl:exit))
-
-
+
+
(defun remove-plist (plist &rest keys)
@@ -568,7 +573,7 @@
((zerop (or (position #\! line) -1))
(funcall shell-fun (subseq line 1)))
(t (format t "~{~A~^ ;~%~}~%"
- (multiple-value-list
+ (multiple-value-list
(ignore-errors (eval (read-from-string line))))))))))
@@ -617,7 +622,7 @@
ret)))
((null char) ret)))
-
+
;;;(defun near-position2 (chars str &key (start 0))
;;; (loop for i in chars
;;; minimize (position i str :start start)))
@@ -679,14 +684,14 @@
(defun append-formated-list (base-str
- lst
+ lst
&key (test-not-fun #'(lambda (x) x nil))
(print-fun #'(lambda (x) x))
(default-str ""))
(let ((str base-str) (first t))
(dolist (i lst)
(cond ((funcall test-not-fun i) nil)
- (t (setq str
+ (t (setq str
(concatenate 'string str
(if first "" ", ")
(format nil "~A"
More information about the clfswm-cvs
mailing list