[clfswm-cvs] CVS clfswm
pbrochard
pbrochard at common-lisp.net
Sat Dec 29 15:20:11 UTC 2007
Update of /project/clfswm/cvsroot/clfswm
In directory clnet:/tmp/cvs-serv13732
Modified Files:
ChangeLog bindings-pager.lisp bindings-second-mode.lisp
clfswm-internal.lisp clfswm-pack.lisp clfswm-pager.lisp
clfswm-second-mode.lisp clfswm-util.lisp clfswm.asd
clfswm.lisp package.lisp tools.lisp
Log Message:
Adapt window only when necessary - Prevent the copy of the same window in the same workspace
--- /project/clfswm/cvsroot/clfswm/ChangeLog 2007/12/25 22:52:16 1.5
+++ /project/clfswm/cvsroot/clfswm/ChangeLog 2007/12/29 15:20:09 1.6
@@ -1,3 +1,38 @@
+2007-12-29 Philippe Brochard <hocwp at free.fr>
+
+ * clfswm-util.lisp (circulate-group-up-copy-window)
+ (circulate-group-down-copy-window)
+ (circulate-workspace-up-copy-group)
+ (circulate-workspace-down-copy-group): Prevent the copy of the
+ same window in the same workspace.
+
+ * bindings-second-mode.lisp (release-copy-selected-window)
+ (release-copy-selected-group): Prevent the copy of the same window
+ in the same workspace.
+
+ * clfswm-pager.lisp (generic-pager-move-window-on-previous-line)
+ (generic-pager-move-window-on-next-line): Remove the copy
+ property.
+ (generic-pager-move-group-on-next-workspace)
+ (generic-pager-move-group-on-previous-workspace): Prevent the copy
+ of the same window in the same workspace.
+
+ * bindings-pager.lisp (mouse-pager-copy-selected-window-release)
+ (mouse-pager-copy-selected-group-release): Prevent the copy of the
+ same window in the same workspace.
+
+ * tools.lisp (setf/=): new macro to set a variable only when
+ necessary.
+
+ * clfswm-internal.lisp (adapt-window-to-group): use set/= to set
+ x, y... only when necessary.
+
+2007-12-28 Philippe Brochard <hocwp at free.fr>
+
+ * clfswm.lisp (handle-configure-notify, *configure-notify-hook*):
+ new function and hook: force windows to stay in its group (solve a
+ bug with the Gimp).
+
2007-12-25 Philippe Brochard <hocwp at free.fr>
* bindings-second-mode.lisp (mouse-motion): use hide-group to have
--- /project/clfswm/cvsroot/clfswm/bindings-pager.lisp 2007/12/22 22:55:26 1.5
+++ /project/clfswm/cvsroot/clfswm/bindings-pager.lisp 2007/12/29 15:20:10 1.6
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Sat Dec 22 23:31:47 2007
+;;; #Date#: Sat Dec 29 16:00:58 2007
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Bindings keys and mouse for pager mode
@@ -248,8 +248,6 @@
(define-pager-key ("Left" :shift :control) 'pager-copy-group-on-previous-workspace)
(define-pager-key ("Right" :shift :control) 'pager-copy-group-on-next-workspace)
-(define-pager-key ("Down" :shift :control) 'pager-copy-window-on-next-line)
-(define-pager-key ("Up" :shift :control) 'pager-copy-window-on-previous-line)
(defmacro define-pager-focus-workspace-by-number (key number)
@@ -312,9 +310,10 @@
(when *pager-motion-object*
(destructuring-bind (workspace group) *pager-motion-object*
(let ((new-workspace (find-cursor-workspace)))
- (remove-group-in-workspace group workspace)
- (add-group-in-workspace (copy-group group) workspace)
- (add-group-in-workspace group new-workspace)))
+ (unless (group-windows-already-in-workspace group new-workspace)
+ (remove-group-in-workspace group workspace)
+ (add-group-in-workspace (copy-group group) workspace)
+ (add-group-in-workspace group new-workspace))))
(pager-draw-display))
(setf *pager-motion-object* nil))
@@ -354,9 +353,10 @@
(when *pager-motion-object*
(destructuring-bind (group window) *pager-motion-object*
(with-group-cursor (new-workspace new-group)
- (add-window-in-group window new-group)
- (add-null-window-in-empty-group group)
- (remove-null-window-in-empty-group new-group)))
+ (unless (window-already-in-workspace window new-workspace)
+ (add-window-in-group window new-group)
+ (add-null-window-in-empty-group group)
+ (remove-null-window-in-empty-group new-group))))
(pager-draw-display))
(setf *pager-motion-object* nil))
@@ -405,4 +405,4 @@
(define-pager-mouse-action (4) 'mouse-pager-rotate-window-up nil)
(define-pager-mouse-action (5) 'mouse-pager-rotate-window-down nil)
-(define-pager-mouse-action ('Motion) 'pager-mouse-motion nil)
\ No newline at end of file
+(define-pager-mouse-action ('Motion) 'pager-mouse-motion nil)
--- /project/clfswm/cvsroot/clfswm/bindings-second-mode.lisp 2007/12/25 22:52:16 1.6
+++ /project/clfswm/cvsroot/clfswm/bindings-second-mode.lisp 2007/12/29 15:20:10 1.7
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Tue Dec 25 23:09:55 2007
+;;; #Date#: Sat Dec 29 15:38:21 2007
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Bindings keys and mouse for second mode
@@ -431,14 +431,14 @@
(hide-group *root* *motion-object*)
(setf (group-x *motion-object*) (+ root-x *motion-dx*)
(group-y *motion-object*) (+ root-y *motion-dy*))
- (adapt-all-window-in-group *motion-object*)
+ ;;(adapt-all-window-in-group *motion-object*) PHIL
(show-all-group (current-workspace) *root* *root-gc* nil))
(:resize-group
(hide-group *root* *motion-object*)
(setf (group-width *motion-object*) (max (+ (group-width *motion-object*) (- root-x *motion-dx*)) 100)
(group-height *motion-object*) (max (+ (group-height *motion-object*) (- root-y *motion-dy*)) 100)
*motion-dx* root-x *motion-dy* root-y)
- (adapt-all-window-in-group *motion-object*)
+ ;;(adapt-all-window-in-group *motion-object*) PHIL
(show-all-group (current-workspace) *root* *root-gc* nil)))))
@@ -464,14 +464,15 @@
(defun copy-selected-group (root-x root-y)
"Copy selected group"
+ (xgrab-pointer *root* 50 51)
(select-group-under-mouse root-x root-y)
(setf *motion-object* (find-group-under-mouse root-x root-y))
(when *motion-object*
- (setf *motion-action* :move-group
+ (setf *motion-action* :copy-group
*motion-object* (copy-group *motion-object*)
*motion-dx* (- (group-x *motion-object*) root-x)
- *motion-dy* (- (group-y *motion-object*) root-y))
- (add-group-in-workspace *motion-object* (current-workspace))))
+ *motion-dy* (- (group-y *motion-object*) root-y))))
+;; (add-group-in-workspace *motion-object* (current-workspace))))
@@ -490,6 +491,21 @@
(select-group-under-mouse root-x root-y))
+(defun release-copy-selected-group (root-x root-y)
+ "Release button"
+ (xgrab-pointer *root* 66 67)
+ (when *motion-object*
+ (unless (group-windows-already-in-workspace *motion-object* (current-workspace))
+ (add-group-in-workspace *motion-object* (current-workspace))
+ (move-group-to *motion-object* (+ root-x *motion-dx*) (+ root-y *motion-dy*))))
+ (setf *motion-action* nil
+ *motion-object* nil
+ *motion-dx* nil
+ *motion-dy* nil)
+ (select-group-under-mouse root-x root-y)
+ (show-all-windows-in-workspace (current-workspace)))
+
+
(defun resize-selected-group (root-x root-y)
"Resize selected group"
@@ -545,7 +561,8 @@
(setf *motion-action* nil)
(select-group-under-mouse root-x root-y)
(when *motion-object*
- (add-window-in-group *motion-object* (current-group)))
+ (unless (window-already-in-workspace *motion-object* (current-workspace))
+ (add-window-in-group *motion-object* (current-group))))
(select-group-under-mouse root-x root-y)
(show-all-windows-in-workspace (current-workspace)))
@@ -556,7 +573,7 @@
(define-mouse-action (1) 'move-selected-group 'release-move-selected-group)
(define-mouse-action (1 :mod-1) 'resize-selected-group 'release-resize-selected-group)
-(define-mouse-action (1 :control) 'copy-selected-group 'release-move-selected-group)
+(define-mouse-action (1 :control) 'copy-selected-group 'release-copy-selected-group)
(define-mouse-action (2) nil 'mouse-leave-second-mode-maximize)
(define-mouse-action (2 :control) nil 'mouse-leave-second-mode)
--- /project/clfswm/cvsroot/clfswm/clfswm-internal.lisp 2007/12/25 22:52:16 1.5
+++ /project/clfswm/cvsroot/clfswm/clfswm-internal.lisp 2007/12/29 15:20:10 1.6
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Tue Dec 25 23:17:49 2007
+;;; #Date#: Sat Dec 29 15:36:43 2007
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Main functions
@@ -63,8 +63,7 @@
do (setf *workspace-list* (rotate-list *workspace-list*))))))
-
-
+
(defun adapt-window-to-group (window group)
(handler-case
(when (and window group)
@@ -74,10 +73,10 @@
(case (window-type window)
(:normal
;;(dbg "adapt 1" (wm-name window) (drawable-height window)) ;;; PHIL
- (setf (drawable-x window) x
- (drawable-y window) y
- (drawable-width window) width
- (drawable-height window) height)
+ (setf/= (drawable-x window) x)
+ (setf/= (drawable-y window) y)
+ (setf/= (drawable-width window) width)
+ (setf/= (drawable-height window) height)
;;(dbg "adapt 2" (drawable-height window))
)
(t (let* ((hints (xlib:wm-normal-hints window))
@@ -87,11 +86,11 @@
most-positive-fixnum)))
;;; Adapt only windows with width and heigth outside group
(when (> hints-width width)
- (setf (drawable-width window) width
- (drawable-x window) x))
+ (setf/= (drawable-width window) width)
+ (setf/= (drawable-x window) x))
(when (> hints-height height)
- (setf (drawable-height window) height
- (drawable-y window) y)))))))
+ (setf/= (drawable-height window) height)
+ (setf/= (drawable-y window) y)))))))
((or match-error window-error drawable-error) (c)
(declare (ignore c)))))
;;(dbg "Adapt error" c))))
@@ -104,6 +103,11 @@
(dolist (window (group-window-list group))
(adapt-window-to-group window group))))
+(defun adapt-all-window-in-workspace (workspace)
+ "Adapt all window to groups in workspace"
+ (dolist (group (workspace-group-list workspace))
+ (adapt-all-window-in-group group)))
+
(defun add-window-in-group (window group)
(when (and window group)
@@ -230,6 +234,7 @@
(dolist (window (group-window-list group))
(hide-window window))))
+
(defun show-all-windows-in-workspace (workspace)
"Show all windows in a workspace"
(dolist (group (workspace-group-list workspace))
@@ -261,6 +266,17 @@
acc))
+(defun group-windows-already-in-workspace (group workspace)
+ "Check if some windows in group group are already in workspace"
+ (some #'(lambda (x)
+ (member x (group-window-list group)))
+ (get-all-windows-in-workspace workspace)))
+
+(defun window-already-in-workspace (window workspace)
+ "Check if window is already in workspace"
+ (member window (get-all-windows-in-workspace workspace)))
+
+
(defun create-workspace-on-request ()
(when *open-next-window-in-new-workspace*
--- /project/clfswm/cvsroot/clfswm/clfswm-pack.lisp 2007/12/21 22:01:14 1.3
+++ /project/clfswm/cvsroot/clfswm/clfswm-pack.lisp 2007/12/29 15:20:10 1.4
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Fri Dec 21 23:00:13 2007
+;;; #Date#: Fri Dec 28 22:13:42 2007
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Tile, pack and fill functions
--- /project/clfswm/cvsroot/clfswm/clfswm-pager.lisp 2007/12/22 22:55:26 1.4
+++ /project/clfswm/cvsroot/clfswm/clfswm-pager.lisp 2007/12/29 15:20:10 1.5
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Sat Dec 22 23:49:48 2007
+;;; #Date#: Sat Dec 29 15:55:52 2007
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Main functions
@@ -447,9 +447,9 @@
(unwind-protect
(catch 'exit-pager
(loop
- (raise-window *pager-window*)
- (display-finish-output *display*)
- (process-event *display* :handler #'pager-handle-event)))
+ (raise-window *pager-window*)
+ (display-finish-output *display*)
+ (process-event *display* :handler #'pager-handle-event)))
(remove-null-window-in-all-empty-group)
(xgrab-pointer *root* 66 67)
(free-gcontext gc)
@@ -537,7 +537,8 @@
(setf (pcursor-workspace *pcursor*)
(mod (1+ (pcursor-workspace *pcursor*))
(length *workspace-list*)))
- (add-group-in-workspace group (find-cursor-workspace)))
+ (unless (group-windows-already-in-workspace group (find-cursor-workspace))
+ (add-group-in-workspace group (find-cursor-workspace))))
(pager-draw-display))
(defun pager-move-group-on-next-workspace ()
@@ -559,7 +560,8 @@
(setf (pcursor-workspace *pcursor*)
(mod (1- (pcursor-workspace *pcursor*))
(length *workspace-list*)))
- (add-group-in-workspace group (find-cursor-workspace)))
+ (unless (group-windows-already-in-workspace group (find-cursor-workspace))
+ (add-group-in-workspace group (find-cursor-workspace))))
(pager-draw-display))
(defun pager-move-group-on-previous-workspace ()
@@ -572,7 +574,7 @@
-(defun generic-pager-move-window-on-next-line (&optional copy)
+(defun generic-pager-move-window-on-next-line ()
"Move the current window to the next line"
(multiple-value-bind (ngroup nwindow group)
(find-group-window-from-cursor (find-cursor-workspace))
@@ -586,8 +588,7 @@
(nth new-nwindow (group-window-list new-group)))
(let ((win (nth nwindow (group-window-list group))))
(when (window-p win)
- (unless copy
- (remove-window-in-group win group))
+ (remove-window-in-group win group)
(when (and (member "--" (group-window-list new-group)
:test #'equal)
(/= nwindow 0))
@@ -602,14 +603,10 @@
"Move the current window to the next line"
(generic-pager-move-window-on-next-line))
-(defun pager-copy-window-on-next-line ()
- "Copy the current window to the next line"
- (generic-pager-move-window-on-next-line t))
-
-(defun generic-pager-move-window-on-previous-line (&optional copy)
+(defun generic-pager-move-window-on-previous-line ()
"Move the current window to the previous line"
(when (plusp (pcursor-line *pcursor*))
(multiple-value-bind (ngroup nwindow group)
@@ -624,8 +621,7 @@
(nth new-nwindow (group-window-list new-group)))
(let ((win (nth nwindow (group-window-list group))))
(when (window-p win)
- (unless copy
- (remove-window-in-group win group))
+ (remove-window-in-group win group)
(when (and (null (group-window-list group))
(/= new-nwindow 0))
(incf (pcursor-line *pcursor*)))
@@ -640,10 +636,6 @@
"Move the current window to the previous line"
(generic-pager-move-window-on-previous-line))
-(defun pager-copy-window-on-previous-line ()
- "Copy the current window to the previous line"
- (generic-pager-move-window-on-previous-line t))
-
;;;,-----
;;;| Delete/Add functions
--- /project/clfswm/cvsroot/clfswm/clfswm-second-mode.lisp 2007/12/21 22:38:14 1.5
+++ /project/clfswm/cvsroot/clfswm/clfswm-second-mode.lisp 2007/12/29 15:20:10 1.6
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Fri Dec 21 23:04:46 2007
+;;; #Date#: Fri Dec 28 22:38:00 2007
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Second mode functions
@@ -84,6 +84,11 @@
(draw-second-mode-window))
+(defun sm-handle-configure-notify (&rest event-slots)
+ (apply #'handle-configure-notify event-slots)
+ (draw-second-mode-window))
+
+
(defun sm-handle-destroy-notify (&rest event-slots)
(apply #'handle-destroy-notify event-slots)
(draw-second-mode-window))
@@ -113,6 +118,7 @@
*sm-motion-notify-hook* #'sm-handle-motion-notify
*sm-key-press-hook* #'sm-handle-key-press
*sm-configure-request-hook* #'sm-handle-configure-request
+ *sm-configure-notify-hook* #'sm-handle-configure-notify
*sm-destroy-notify-hook* #'sm-handle-destroy-notify
*sm-enter-notify-hook* #'sm-handle-enter-notify
*sm-exposure-hook* #'sm-handle-exposure
@@ -125,7 +131,7 @@
(defun sm-handle-event (&rest event-slots &key display event-key &allow-other-keys)
(declare (ignore display))
- ;;(dbg event-key)
+ ;;(dbg event-key)
(handler-case
(case event-key
(:button-press (call-hook *sm-button-press-hook* event-slots))
@@ -133,6 +139,7 @@
(: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))
@@ -176,10 +183,10 @@
(unwind-protect
(catch 'exit-second-loop
(loop
- (raise-window *sm-window*)
- (display-finish-output *display*)
- (process-event *display* :handler #'sm-handle-event)
- (display-finish-output *display*)))
+ (raise-window *sm-window*)
+ (display-finish-output *display*)
+ (process-event *display* :handler #'sm-handle-event)
+ (display-finish-output *display*)))
(free-gcontext *sm-gc*)
(close-font *sm-font*)
(destroy-window *sm-window*)
--- /project/clfswm/cvsroot/clfswm/clfswm-util.lisp 2007/12/26 22:49:35 1.5
+++ /project/clfswm/cvsroot/clfswm/clfswm-util.lisp 2007/12/29 15:20:10 1.6
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Wed Dec 26 23:45:06 2007
+;;; #Date#: Sat Dec 29 15:41:24 2007
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Utility
@@ -143,7 +143,8 @@
(let ((window (current-window)))
(setf (workspace-group-list (current-workspace))
(rotate-list (workspace-group-list (current-workspace))))
- (add-window-in-group window (current-group)))
+ (unless (window-already-in-workspace window (current-workspace))
+ (add-window-in-group window (current-group))))
(adapt-window-to-group (current-window) (current-group))
(focus-window (current-window))
(show-all-group (current-workspace)))
@@ -184,7 +185,8 @@
(let ((window (current-window)))
(setf (workspace-group-list (current-workspace))
(anti-rotate-list (workspace-group-list (current-workspace))))
- (add-window-in-group window (current-group)))
+ (unless (window-already-in-workspace window (current-workspace))
+ (add-window-in-group window (current-group))))
(adapt-window-to-group (current-window) (current-group))
(focus-window (current-window))
(show-all-group (current-workspace)))
@@ -227,7 +229,8 @@
(hide-all-windows-in-workspace (current-workspace))
(let ((group (current-group)))
(setf *workspace-list* (rotate-list *workspace-list*))
- (add-group-in-workspace (copy-group group) (current-workspace)))
+ (unless (group-windows-already-in-workspace group (current-workspace))
+ (add-group-in-workspace (copy-group group) (current-workspace))))
(show-all-windows-in-workspace (current-workspace)))
@@ -255,7 +258,8 @@
(hide-all-windows-in-workspace (current-workspace))
(let ((group (current-group)))
(setf *workspace-list* (anti-rotate-list *workspace-list*))
- (add-group-in-workspace (copy-group group) (current-workspace)))
+ (unless (group-windows-already-in-workspace group (current-workspace))
+ (add-group-in-workspace (copy-group group) (current-workspace))))
(show-all-windows-in-workspace (current-workspace)))
--- /project/clfswm/cvsroot/clfswm/clfswm.asd 2007/12/22 22:55:26 1.4
+++ /project/clfswm/cvsroot/clfswm/clfswm.asd 2007/12/29 15:20:10 1.5
@@ -2,7 +2,7 @@
;;;; Author: Philippe Brochard <hocwp at free.fr>
;;;; ASDF System Definition
;;;
-;;; #date#: Sat Dec 22 22:26:18 2007
+;;; #date#: Sat Dec 29 15:08:01 2007
(in-package #:asdf)
@@ -27,7 +27,7 @@
(:file "clfswm-keys"
:depends-on ("package" "config" "xlib-util" "keysyms"))
(:file "clfswm-internal"
- :depends-on ("xlib-util" "clfswm-keys" "netwm-util"))
+ :depends-on ("xlib-util" "clfswm-keys" "netwm-util" "tools"))
(:file "clfswm-second-mode"
:depends-on ("package" "clfswm-internal"))
(:file "clfswm"
--- /project/clfswm/cvsroot/clfswm/clfswm.lisp 2007/12/21 22:38:14 1.4
+++ /project/clfswm/cvsroot/clfswm/clfswm.lisp 2007/12/29 15:20:10 1.5
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Fri Dec 21 23:04:39 2007
+;;; #Date#: Sat Dec 29 15:33:46 2007
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Main functions
@@ -75,6 +75,11 @@
+(defun handle-configure-notify (&rest event-slots)
+ (declare (ignore event-slots))
+ (adapt-all-window-in-workspace (current-workspace)))
+
+
(defun handle-map-request (&rest event-slots &key window send-event-p &allow-other-keys)
(declare (ignore event-slots))
(unless send-event-p
@@ -121,6 +126,7 @@
;;; CONFIG: Main mode hooks
(setf *key-press-hook* #'handle-key-press
*configure-request-hook* #'handle-configure-request
+ *configure-notify-hook* #'handle-configure-notify
*destroy-notify-hook* #'handle-destroy-notify
*enter-notify-hook* #'handle-enter-notify
*exposure-hook* #'handle-exposure
@@ -139,6 +145,7 @@
(:button-press (call-hook *button-press-hook* event-slots))
(:key-press (call-hook *key-press-hook* event-slots))
(:configure-request (call-hook *configure-request-hook* event-slots))
+ (:configure-notify (call-hook *configure-notify-hook* event-slots))
(:map-request (call-hook *map-request-hook* event-slots))
(:unmap-notify (call-hook *unmap-notify-hook* event-slots))
(:destroy-notify (call-hook *destroy-notify-hook* event-slots))
--- /project/clfswm/cvsroot/clfswm/package.lisp 2007/12/21 22:01:14 1.7
+++ /project/clfswm/cvsroot/clfswm/package.lisp 2007/12/29 15:20:10 1.8
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Fri Dec 21 23:00:40 2007
+;;; #Date#: Fri Dec 28 22:32:54 2007
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Package definition
@@ -91,6 +91,7 @@
(defparameter *button-press-hook* nil)
(defparameter *key-press-hook* nil)
(defparameter *configure-request-hook* nil)
+(defparameter *configure-notify-hook* nil)
(defparameter *create-notify-hook* nil)
(defparameter *destroy-notify-hook* nil)
(defparameter *enter-notify-hook* nil)
@@ -107,6 +108,7 @@
(defparameter *sm-motion-notify-hook* nil)
(defparameter *sm-key-press-hook* nil)
(defparameter *sm-configure-request-hook* nil)
+(defparameter *sm-configure-notify-hook* nil)
(defparameter *sm-map-request-hook* nil)
(defparameter *sm-unmap-notify-hook* nil)
(defparameter *sm-destroy-notify-hook* nil)
--- /project/clfswm/cvsroot/clfswm/tools.lisp 2007/12/21 22:01:14 1.3
+++ /project/clfswm/cvsroot/clfswm/tools.lisp 2007/12/29 15:20:10 1.4
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Fri Dec 21 23:00:43 2007
+;;; #Date#: Sat Dec 29 15:08:48 2007
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: General tools
@@ -31,6 +31,7 @@
(defpackage tools
(:use common-lisp)
(:export :dbg
+ :setf/=
:create-symbol
:split-string
:expand-newline
@@ -111,6 +112,15 @@
;;; Tools
+
+(defmacro setf/= (var val)
+ "Set var to val only when var not equal to val"
+ (let ((gval (gensym)))
+ `(let ((,gval ,val))
+ (when (/= ,var ,gval)
+ (setf ,var ,gval)))))
+
+
(defun create-symbol (&rest names)
"Return a new symbol from names"
(intern (string-upcase (apply #'concatenate 'string names))))
More information about the clfswm-cvs
mailing list