[Eclipse-cvs] CVS update: eclipse/Makefile.in eclipse/eclipse.lisp eclipse/gestures.lisp eclipse/global.lisp eclipse/input.lisp eclipse/misc.lisp eclipse/move-resize.lisp eclipse/package.lisp eclipse/programmed-tasks.lisp eclipse/virtual-screen.lisp eclipse/widgets.lisp eclipse/wm.lisp
Iban Hatchondo
ihatchondo at common-lisp.net
Mon Oct 6 17:57:27 UTC 2003
Update of /project/eclipse/cvsroot/eclipse
In directory common-lisp.net:/tmp/cvs-serv32136
Modified Files:
Makefile.in eclipse.lisp gestures.lisp global.lisp input.lisp
misc.lisp move-resize.lisp package.lisp programmed-tasks.lisp
virtual-screen.lisp widgets.lisp wm.lisp
Log Message:
- Window rotation (Alt-Tab) re-designed. It now works as in almost
every window managers. Press Alt-Tab once will raise the next
application, on the current desktop, according to the current
stacking order. If Alt is released then pressing again Alt-Tab will
put back the precedent application. Otherwise if you kipped Alt down
then Tab again and the next application will be brought on top of the
others, and the precedent one is back on its depth. And so on
until you come back on the first one.
The same mechanism is available with say Alt-a. It just rotate
windows on the other sens.
- The window rotation may be verbose by displaying a small window
indicating the name and the icon, if provided, of the application
that comes on top of the others.
To disable it do (setf *verbose-window-cycling* nil) in your eclipse
config file.
- The window rotation may also cycle the current desktop iconified
applications. To disable it do (setf *cycle-icons-p* nil) in
your eclipse config file.
- Screen edges are now resistant.
- fix menu bug. They don't anymore appear below their applications.
- a maximized window does not allow anymore to be resized in the
directions in which it has been maximized.
- the message-box may now display a centered pixmap before the text.
- package.lisp updated.
- man page updated.
- changelog updated.
Date: Mon Oct 6 13:57:26 2003
Author: ihatchondo
Index: eclipse/Makefile.in
diff -u eclipse/Makefile.in:1.6 eclipse/Makefile.in:1.7
--- eclipse/Makefile.in:1.6 Mon Apr 7 09:35:32 2003
+++ eclipse/Makefile.in Mon Oct 6 13:57:25 2003
@@ -1,5 +1,5 @@
# -*- Mode: Makefile -*-
-# $Id: Makefile.in,v 1.6 2003/04/07 13:35:32 hatchond Exp $
+# $Id: Makefile.in,v 1.7 2003/10/06 17:57:25 ihatchondo Exp $
#
# Makefile for Eclipse window manager.
@@ -101,7 +101,8 @@
for theme in ${themes} ; do \
test -f "themes/$$theme/theme.o" && \
$(install) -d ${themedir}/$$theme && \
- for file in themes/$$theme/* ; do \
+ $(install) ${themedir}/$$theme/theme.o && \
+ for file in themes/$$theme/*.pnm ; do \
$(install) $$file ${themedir}/$$theme/. ; \
done ; \
done ; \
Index: eclipse/eclipse.lisp
diff -u eclipse/eclipse.lisp:1.9 eclipse/eclipse.lisp:1.10
--- eclipse/eclipse.lisp:1.9 Tue Sep 30 08:18:36 2003
+++ eclipse/eclipse.lisp Mon Oct 6 13:57:26 2003
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: eclipse.lisp,v 1.9 2003/09/30 12:18:36 hatchond Exp $
+;;; $Id: eclipse.lisp,v 1.10 2003/10/06 17:57:26 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2002 Iban HATCHONDO
@@ -150,6 +150,7 @@
:exposures :OFF
:font (xlib:open-font display *font-name*)))
(setf (xlib:window-cursor root-window) (root-default-cursor *root*))
+ (setf (slot-value *root* 'gcontext) *gcontext*)
(unless (root-decoration-theme *root*)
(setf (decoration-theme) "microGUI"))
(init-edges-cursors))))
Index: eclipse/gestures.lisp
diff -u eclipse/gestures.lisp:1.8 eclipse/gestures.lisp:1.9
--- eclipse/gestures.lisp:1.8 Tue Sep 30 08:18:36 2003
+++ eclipse/gestures.lisp Mon Oct 6 13:57:26 2003
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: gestures.lisp,v 1.8 2003/09/30 12:18:36 hatchond Exp $
+;;; $Id: gestures.lisp,v 1.9 2003/10/06 17:57:26 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2002 Iban HATCHONDO
@@ -30,11 +30,13 @@
(defun lookup-keystroke (code state)
"Find the associated callback if any for this pair code modifier state."
- (gethash (cons code state) *keystroke-map*))
+ (or (gethash (cons code state) *keystroke-map*)
+ (gethash (cons code #x8000) *keystroke-map*)))
(defun lookup-mouse-stroke (button state)
"Find the associated callback if any for this pair button modifier state."
- (gethash (cons button state) *mouse-stroke-map*))
+ (or (gethash (cons button state) *mouse-stroke-map*)
+ (gethash (cons button #x8000) *keystroke-map*)))
(defun keycode-registered-p (keycode &optional (count 1))
"Returns t if this keycode is used for any keystroke."
@@ -104,7 +106,7 @@
:keysyms (mapcar #'kb:keyname->keysym key-name-set)
:default-modifiers-p default-modifiers-p
:modifiers modifiers
- :action action))
+ :action (or action (action-key->lambda name))))
(defun keystroke-p (stroke)
(typep stroke 'keystroke))
@@ -129,7 +131,7 @@
:button (list button)
:default-modifiers-p default-modifiers-p
:modifiers modifiers
- :action action))
+ :action (or action (action-key->lambda name))))
(defun mouse-stroke-p (stroke)
(typep stroke 'mouse-stroke))
@@ -156,10 +158,8 @@
(defun action-key->lambda (action-keyword)
"Returns the associated predefined callback for the given action keyword."
(case action-keyword
- (:switch-win-up
- (action () (:press (circulate-window *root* :direction :above))))
- (:switch-win-down
- (action () (:press (circulate-window *root* :direction :below))))
+ (:switch-win-up #'(lambda (e) (circulate-window-up-and-down e :above)))
+ (:switch-win-down #'(lambda (e) (circulate-window-up-and-down e :below)))
(:switch-screen-left
(action (:press (change-vscreen *root* :direction #'-)) ()))
(:switch-screen-right
@@ -207,7 +207,7 @@
for mask in (translate-modifiers dpy modifiers) do
(loop for key in (stroke-keys ,stroke) do
(unrealize (,dest-window :mouse-p ,mouse-p) key mask)
- (when (and default-modifiers-p (not (eql mask :any)))
+ (when (and default-modifiers-p (not (eql mask #x8000)))
(when caps-l
(unrealize (,dest-window :mouse-p ,mouse-p)
key (+ mask caps-l)))
@@ -218,40 +218,38 @@
(unrealize (,dest-window :mouse-p ,mouse-p)
key (+ mask num-l caps-l))))))))
-(defmacro realize ((window &key mouse-p) code mask action-keyword action)
+(defmacro realize ((window &key mouse-p) code mask action)
`(progn
,@(if mouse-p
- `((setf (gethash (cons ,code ,mask) *mouse-stroke-map*)
- (or ,action (action-key->lambda ,action-keyword)))
+ `((setf (gethash (cons ,code ,mask) *mouse-stroke-map*) ,action)
(xlib:grab-button ,window
,code
'(:button-press)
:modifiers ,mask
:sync-pointer-p t))
- `((setf (gethash (cons ,code ,mask) *keystroke-map*)
- (or ,action (action-key->lambda ,action-keyword)))
+ `((setf (gethash (cons ,code ,mask) *keystroke-map*) ,action)
(setf (aref *registered-keycodes* ,code) 1)
(xlib:grab-key ,window ,code :modifiers ,mask :owner-p nil)))))
(defmacro define-combo-internal (stroke dest-window &key mouse-p)
- `(with-slots (name modifiers default-modifiers-p action) ,stroke
+ `(with-slots (modifiers default-modifiers-p action) ,stroke
(loop with dpy = (xlib:drawable-display ,dest-window)
with num-l = (kb:modifier->modifier-mask dpy :NUM-LOCK)
with caps-l = (kb:modifier->modifier-mask dpy :CAPS-LOCK)
for mask in (translate-modifiers dpy modifiers) do
(loop for key in (stroke-keys ,stroke) do
(realize (,dest-window :mouse-p ,mouse-p)
- key mask name action)
- (when (and default-modifiers-p (not (eql mask :any)))
+ key mask action)
+ (when (and default-modifiers-p (not (eql mask #x8000)))
(when caps-l
(realize (,dest-window :mouse-p ,mouse-p)
- key (+ mask caps-l) name action ))
+ key (+ mask caps-l) action ))
(when num-l
(realize (,dest-window :mouse-p ,mouse-p)
- key (+ mask num-l) name action))
+ key (+ mask num-l) action))
(when (and num-l caps-l)
(realize (,dest-window :mouse-p ,mouse-p)
- key (+ mask num-l caps-l) name action)))))))
+ key (+ mask num-l caps-l) action)))))))
(defun define-key-combo (name &key keys
(default-modifiers-p t)
@@ -326,3 +324,57 @@
(xlib:grab-pointer (event-child event) +pointer-event-mask+)
(menu-3-process event widget :key action)
(funcall (define-menu-3 action))))
+
+;;; Hook and Callbacks for :switch-win-{up, down} keystrokes.
+
+(defvar *depth* nil)
+(defvar *current-widget-info* nil)
+
+(defun initialize-circulate-window (root-window dpy)
+ "Initialize gestures internal hooks before circulating windows."
+ (loop with map = *keystroke-map*
+ for mod in (stroke-modifiers (gethash :switch-win-up *keystrokes*))
+ for code = (unless (eq mod :and) (kb:keyname->keycodes dpy mod))
+ when code
+ do (setf (gethash (cons (if (listp code) (car code) code) #x8000) map)
+ #'circulate-window-modifier-callback))
+ (xlib:grab-keyboard root-window)
+ (unless *current-widget-info*
+ (setf *current-widget-info* (create-message-box nil :parent root-window)))
+ (setf *depth* 0))
+
+(defun circulate-window-modifier-callback (event)
+ (when (typep event 'key-release)
+ (xlib:ungrab-keyboard *display*)
+ (loop with map = *keystroke-map*
+ for mod in (stroke-modifiers (gethash :switch-win-up *keystrokes*))
+ for code = (unless (eq mod :and) (kb:keyname->keycodes *display* mod))
+ when code
+ do (remhash (cons (if (listp code) (car code) code) #x8000) map))
+ (let ((widget (lookup-widget (input-focus *display*))))
+ (when widget (setf (application-wants-iconic-p widget) nil)))
+ (xlib:unmap-window (widget-window *current-widget-info*))
+ (setf *depth* nil)))
+
+(defun circulate-window-up-and-down (event dir)
+ "Make window circulating according to the `dir' argument (or :above :below)."
+ (when (typep event 'key-press)
+ (with-slots ((root-win root)) event
+ (unless *depth*
+ (initialize-circulate-window root-win (xlib:drawable-display root-win)))
+ (if (eq dir :above) (incf *depth*) (decf *depth*))
+ (let ((widget (circulate-window
+ (lookup-widget root-win)
+ :direction dir
+ :nth *depth*
+ :icon-p *cycle-icons-p*)))
+ (when (and *verbose-window-cycling* widget)
+ (with-slots (window)
+ (if (decoration-p widget) (get-child widget :application) widget)
+ (setf (message-pixmap *current-widget-info*)
+ (clx-ext::wm-hints-icon-pixmap window))
+ (setf (button-item-to-draw *current-widget-info*) (wm-name window)))
+ (with-slots (window) *current-widget-info*
+ (xlib:map-window window)
+ (setf (xlib:window-priority window) :above)
+ (repaint *current-widget-info* nil nil)))))))
Index: eclipse/global.lisp
diff -u eclipse/global.lisp:1.11 eclipse/global.lisp:1.12
--- eclipse/global.lisp:1.11 Tue Sep 30 08:18:36 2003
+++ eclipse/global.lisp Mon Oct 6 13:57:26 2003
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: global.lisp,v 1.11 2003/09/30 12:18:36 hatchond Exp $
+;;; $Id: global.lisp,v 1.12 2003/10/06 17:57:26 ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2001, 2002 Iban HATCHONDO
@@ -55,12 +55,15 @@
(defvar +xa-wm+ nil)
;; Default value of all the "customisable" environment variables
+(defparameter *menu-1-exit-p* t)
(defparameter *close-display-p* t)
(defparameter *menu-1-items* nil)
(defparameter *change-desktop-message-active-p* t)
(defparameter *verbose-move* t)
(defparameter *verbose-resize* t)
+(defparameter *verbose-window-cycling* t)
(defparameter *warp-pointer-when-cycle* t)
+(defparameter *cycle-icons-p* t "Alt-Tab shows or not iconified windows.")
(defparameter *focus-new-mapped-window* t)
(defparameter *focus-when-window-cycle* t)
(defparameter *double-click-speed* 200 "the speed of the double click")
@@ -79,8 +82,8 @@
"icon box fill strategy, one of :{top,bottom}-{left,right}")
(defparameter *icon-box-sort-function* nil
"Function determining icon order within the box.
-NIL corresponds to the default which is to sort on order of creation
-\(aka `icon-sort-creation-order'\).")
+ NIL corresponds to the default which is to sort on order of creation
+ \(aka `icon-sort-creation-order'\).")
(defsetf font-name () (name)
`(setf *font-name* ,name
@@ -101,7 +104,7 @@
(defmacro deftypedparameter (type symbol value &optional documentation)
"define a parameter with the same syntax and behavior as defparameter
- except that its type must be given first."
+ except that its type must be given first."
`(progn
(defparameter ,symbol ,value ,documentation)
(declaim (type ,type ,symbol))))
Index: eclipse/input.lisp
diff -u eclipse/input.lisp:1.17 eclipse/input.lisp:1.18
--- eclipse/input.lisp:1.17 Tue Sep 30 08:18:36 2003
+++ eclipse/input.lisp Mon Oct 6 13:57:26 2003
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: input.lisp,v 1.17 2003/09/30 12:18:36 hatchond Exp $
+;;; $Id: input.lisp,v 1.18 2003/10/06 17:57:26 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
@@ -283,8 +283,8 @@
(set-focus input-model window (event-time event)))))
(defmethod event-process ((event button-press) (application application))
- (xlib:allow-events *display* :replay-pointer)
- (put-on-top application))
+ (put-on-top application)
+ (xlib:allow-events *display* :replay-pointer))
(defmethod event-process ((event focus-out) (application application))
(with-slots (master) application
@@ -294,7 +294,7 @@
(defmethod event-process ((event focus-in) (application application))
(with-slots (master window) application
- (unless (eql (event-mode event) :ungrab)
+ (unless (eql (event-mode event) :grab)
(when master (dispatch-repaint master :focus t))
(setf (netwm:net-active-window *root-window*) window))))
@@ -472,3 +472,8 @@
(defmethod event-process ((event button-release) (icon icon))
(when (icon-desiconify-p icon)
(uniconify icon)))
+
+;;; Events for Message Box
+
+(defmethod event-process ((event visibility-notify) (box box-button))
+ (setf (window-priority (widget-window box)) :above))
\ No newline at end of file
Index: eclipse/misc.lisp
diff -u eclipse/misc.lisp:1.11 eclipse/misc.lisp:1.12
--- eclipse/misc.lisp:1.11 Tue Sep 16 10:47:12 2003
+++ eclipse/misc.lisp Mon Oct 6 13:57:26 2003
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: misc.lisp,v 1.11 2003/09/16 14:47:12 hatchond Exp $
+;;; $Id: misc.lisp,v 1.12 2003/10/06 17:57:26 ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2002 Iban HATCHONDO
@@ -121,7 +121,7 @@
(defun motif-wm-decoration (window)
"Returns the state (or :on :off) of the :_MOTIF_WM_HINT property that
- indicates the application wants or not to be decorated."
+ indicates the application wants or not to be decorated."
(let ((prop (xlib:get-property window :_MOTIF_WM_HINTS)))
(or (and prop (logbitp 1 (first prop)) (zerop (third prop)) :OFF) :ON)))
@@ -133,7 +133,7 @@
(defun send-wm-protocols-client-message (window atom &rest data)
"Send a client-message of type :wm-protocol to the specified window
- with data being the given atom plus the rest of the function args."
+ with data being the given atom plus the rest of the function args."
(xlib:send-event window
:client-message
nil
@@ -144,8 +144,8 @@
(defsetf window-priority (window &optional sibling) (priority)
"Set the window priority such as (setf xlib:window-priority) but
- also invoke update-client-list-stacking to reflect the priority
- change in all the root properties that are involved in."
+ also invoke update-client-list-stacking to reflect the priority
+ change in all the root properties that are involved in."
`(progn
(setf (xlib:window-priority ,window ,sibling) ,priority)
(update-client-list-stacking *root*)))
@@ -160,8 +160,8 @@
(defun query-application-tree (root-window)
"Returns the children of the specified root-window as if all applications
- where undecorated. The children are returned as a sequence of windows in
- current stacking order, from bottom-most (first) to top-most (last)."
+ where undecorated. The children are returned as a sequence of windows in
+ current stacking order, from bottom-most (first) to top-most (last)."
(loop for window in (xlib:query-tree root-window)
for obj = (lookup-widget window)
for appw = (typecase obj
@@ -175,8 +175,8 @@
(defun run-application (program &rest arguments)
"Returns a lambda of zero arguments which when funcalled will try to
- run the program named `program' with arguments `arguments'. If the
- invocation failed a pop-up window will appear reporting the error."
+ run the program named `program' with arguments `arguments'. If the
+ invocation failed a pop-up window will appear reporting the error."
(lambda ()
(catch 'wrong-name
(handler-bind ((error #'handle-wrong-name-condition))
Index: eclipse/move-resize.lisp
diff -u eclipse/move-resize.lisp:1.5 eclipse/move-resize.lisp:1.6
--- eclipse/move-resize.lisp:1.5 Tue Sep 30 08:18:36 2003
+++ eclipse/move-resize.lisp Mon Oct 6 13:57:26 2003
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: move-resize.lisp,v 1.5 2003/09/30 12:18:36 hatchond Exp $
+;;; $Id: move-resize.lisp,v 1.6 2003/10/06 17:57:26 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
@@ -33,8 +33,7 @@
(defun initialize-geometry-info-box ()
(unless *geometry-info-box*
- (setf *geometry-info-box*
- (create-message-box '("nil") :parent *root-window* :border-width 0)))
+ (setf *geometry-info-box* (create-message-box nil :parent *root-window*)))
(with-slots (window) *geometry-info-box*
(xlib:map-window window)
(setf (xlib:window-priority window) :above)))
@@ -114,16 +113,28 @@
(defun initialize-resize (master edge pointer-event)
"Initialize the internal settings for the resize process."
- (setf (window-priority (widget-window master)) :above
- (decoration-active-p master) t)
+ (setf (window-priority (widget-window master)) :above)
(if (base-widget-p edge)
(where-is-pointer edge)
(with-slots (root-x root-y) pointer-event
- (find-corner root-x root-y (widget-window master)))))
+ (find-corner root-x root-y (widget-window master))))
+ (let ((prop (netwm:net-wm-state (get-child master :application :window t))))
+ (when (member :_net_wm_state_maximized_vert prop)
+ (case *card-point*
+ ((:ne :se) (setf *card-point* :east))
+ ((:nw :sw) (setf *card-point* :west))
+ ((:north :south) (setf *card-point* nil))))
+ (when (member :_net_wm_state_maximized_horz prop)
+ (case *card-point*
+ ((:ne :nw) (setf *card-point* :north))
+ ((:se :sw) (setf *card-point* :south))
+ ((:east :west) (setf *card-point* nil))))
+ (setf (decoration-active-p master) (if *card-point* t nil))))
(defgeneric resize-from (widget)
- (:documentation "Resize an application or a master according
- to the given master or application respectively."))
+ (:documentation
+ "Resize an application or a master according to the given master or
+ application respectively."))
(defmethod resize-from ((master decoration))
(declare (optimize (speed 3) (safety 0)))
@@ -166,7 +177,7 @@
(defun find-corner (root-x root-y window)
"Initialize the resize process when activated from somewhere else
- than a decoration edge."
+ than a decoration edge."
(declare (optimize (speed 3) (safety 0))
(type xlib:int16 root-x root-y))
(multiple-value-bind (x y w h) (window-geometry window)
@@ -183,7 +194,7 @@
(defun check-size (size base inc min-size max-size)
"If the given size respects all the given constraints, then return size.
- Otherwise returns the nearest satisfying size."
+ Otherwise returns the nearest satisfying size."
(declare (optimize (speed 3) (safety 0))
(type xlib:card16 size base inc min-size max-size))
(if (< min-size size max-size)
@@ -287,7 +298,20 @@
(with-slots (window active-p gcontext) widget
(when active-p
(let ((new-x (- (the (signed-byte 16) (event-root-x event)) *delta-x*))
- (new-y (- (the (signed-byte 16) (event-root-y event)) *delta-y*)))
+ (new-y (- (the (signed-byte 16) (event-root-y event)) *delta-y*))
+ (scr-w (screen-width)) (scr-h (screen-height)))
+ (declare (type (signed-byte 16) new-x new-y))
+ (declare (type (unsigned-byte 16) scr-w scr-h))
+ (multiple-value-bind (x y w h)
+ (window-geometry (if (eq mode :box) (widget-window *clone*) window))
+ (declare (type (signed-byte 16) x y))
+ (declare (type (unsigned-byte 16) w h))
+ (when (and (>= x 0) (< -40 new-x 0)) (setf new-x 0))
+ (when (and (>= y 0) (< -40 new-y 0)) (setf new-y 0))
+ (when (and (>= (- scr-w x w) 0) (< -40 (- scr-w new-x w) 0))
+ (setf new-x (- scr-w w)))
+ (when (and (>= (- scr-h y h) 0) (< -40 (- scr-h new-y h) 0))
+ (setf new-y (- scr-h h))))
(when verbose-p (display-coordinates new-x new-y))
(if (and (decoration-p widget) (eql mode :box))
(with-slots (window) *clone*
Index: eclipse/package.lisp
diff -u eclipse/package.lisp:1.8 eclipse/package.lisp:1.9
--- eclipse/package.lisp:1.8 Tue Sep 30 08:18:36 2003
+++ eclipse/package.lisp Mon Oct 6 13:57:26 2003
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: User -*-
-;;; $Id: package.lisp,v 1.8 2003/09/30 12:18:36 hatchond Exp $
+;;; $Id: package.lisp,v 1.9 2003/10/06 17:57:26 ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2002 Iban HATCHONDO
@@ -73,6 +73,7 @@
"BASE-WIDGET-P" ;function
"BUTTON-P" ;function
"CHECK-SIZE" ;function
+ "CIRCULATE-WINDOW-UP-AND-DOWN" ;function
"COPY-GEOMETRY" ;function
"CREATE-APPLICATION" ;function
"CREATE-BUTTON" ;function
Index: eclipse/programmed-tasks.lisp
diff -u eclipse/programmed-tasks.lisp:1.4 eclipse/programmed-tasks.lisp:1.5
--- eclipse/programmed-tasks.lisp:1.4 Tue Sep 30 08:18:36 2003
+++ eclipse/programmed-tasks.lisp Mon Oct 6 13:57:26 2003
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: PROGRAMMED-TASKS -*-
-;;; $Id: programmed-tasks.lisp,v 1.4 2003/09/30 12:18:36 hatchond Exp $
+;;; $Id: programmed-tasks.lisp,v 1.5 2003/10/06 17:57:26 ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2001 Iban HATCHONDO
@@ -36,7 +36,7 @@
(defun arm-timer (delta-time lambda)
"Arm a timer that expires in delta-time (unit is second). At expiration
- the given lambda (with no parameter) will be executed."
+ the given lambda (with no parameter) will be executed."
(push (cons (+ delta-time (get-universal-time)) lambda)
preprogrammed-tasks))
Index: eclipse/virtual-screen.lisp
diff -u eclipse/virtual-screen.lisp:1.8 eclipse/virtual-screen.lisp:1.9
--- eclipse/virtual-screen.lisp:1.8 Tue Sep 16 10:24:41 2003
+++ eclipse/virtual-screen.lisp Mon Oct 6 13:57:26 2003
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: virtual-screen.lisp,v 1.8 2003/09/16 14:24:41 hatchond Exp $
+;;; $Id: virtual-screen.lisp,v 1.9 2003/10/06 17:57:26 ihatchondo Exp $
;;;
;;; Copyright (C) 2002 Iban HATCHONDO
;;; contact : hatchond at yahoo.fr
@@ -48,12 +48,12 @@
(defun current-vscreen (win)
"Get the current virtual screen index. The window parameter must be
- the window that owns the win_workspace or _net_current_desktop property."
+ the window that owns the win_workspace or _net_current_desktop property."
(or (netwm:net-current-desktop win) (gnome:win-workspace win) 0))
(defun number-of-virtual-screens (win)
"Get the number of virtual screens. The window parameter must be the window
- that owns the win_workspace_count or _net_number_of_desktops property."
+ that owns the win_workspace_count or _net_number_of_desktops property."
(or (gnome:win-workspace-count win) (netwm:net-number-of-desktops win) 1))
(defsetf number-of-virtual-screens () (n)
@@ -97,6 +97,7 @@
(let ((widget (lookup-widget (input-focus *display*))))
(when (application-p widget)
(setf (application-wants-focus-p widget) t))))
+ (xlib:set-input-focus *display* :pointer-root :pointer-root)
(with-pointer-grabbed (window nil)
(map-or-unmap-vscreen #'xlib:map-window new)
(map-or-unmap-vscreen #'xlib:unmap-window cur)))
@@ -109,7 +110,7 @@
(defun get-screen-content (scr-num &key iconify-p)
"Returns the list of application's windows that represent the contents
- of the given virtual screen. Use :iconify-p t to includes iconfied windows"
+ of the given virtual screen. Use :iconify-p t to includes iconfied windows"
(loop for win in (query-application-tree *root-window*)
when (window-belongs-to-vscreen-p win scr-num iconify-p) collect win))
@@ -127,23 +128,45 @@
(unless given-p
(xlib:set-input-focus *display* :pointer-root :pointer-root))))
-(defmethod circulate-window ((root root) &key direction)
- (let ((screen-wins (get-screen-content (current-desk))))
- (or screen-wins (return-from circulate-window nil))
- (when (= 1 (length screen-wins)) (setf direction :above))
- (let* ((above-p (eq direction :above))
- (wins (if above-p screen-wins (reverse screen-wins)))
- (desktop (and (eql direction :below) (get-root-desktop root t)))
- (one (lookup-widget (first wins)))
- (two (if above-p one (lookup-widget (second wins)))))
- (with-slots (master) one (when master (setf one master)))
- (with-slots (master) two (when master (setf two master)))
- (when (and (eq direction :below) desktop)
- (setf direction :above above-p t))
- (with-slots (window) two
- (and (not above-p) *warp-pointer-when-cycle*
- (xlib:warp-pointer window 8 5))
- (setf (window-priority (widget-window one) desktop) direction)
- (and above-p *warp-pointer-when-cycle* (xlib:warp-pointer window 8 5))
- (and (eq *focus-type* :on-click) *focus-when-window-cycle*
- (focus-widget two 0))))))
+(defmethod circulate-window ((root root) &key direction (nth 0) icon-p)
+ (let* ((wins (reverse (get-screen-content (current-desk) :iconify-p icon-p)))
+ (length (length wins)))
+ (or wins (return-from circulate-window nil))
+ (setf nth (mod nth length))
+ (let ((above-p (eq direction :above))
+ (focus-dest (nth nth wins))
+ (first (lookup-widget (car wins))))
+ ;; Grab the pointer to avoid enter notify events race concurrence
+ ;; between the window hierarchy change and the warp-pointer call.
+ (with-pointer-grabbed ((widget-window root) nil)
+ (when (and (/= length 1) icon-p (application-wants-iconic-p first))
+ (iconify first))
+ (flet ((set-window-priority (window sibling priority)
+ (with-slots (master) (lookup-widget window)
+ (when master (setf window (widget-window master))))
+ (when (lookup-widget sibling)
+ (with-slots (master) (lookup-widget sibling)
+ (when master (setf sibling (widget-window master)))))
+ (setf (window-priority window sibling) priority)))
+ (cond ((= length 1) (set-window-priority focus-dest nil :above))
+ ((= nth 0)
+ (let ((sibling (if above-p (last wins) (cdr wins))))
+ (set-window-priority (car wins) (car sibling) :below)
+ (setf focus-dest (second wins))))
+ ((or (and (= nth (1- length)) (not above-p))
+ (and (= nth 1) above-p))
+ (set-window-priority focus-dest nil :above))
+ (t (unless above-p
+ (setf focus-dest (nth (incf nth) wins)))
+ (set-window-priority (car wins) focus-dest :below)
+ (set-window-priority focus-dest nil :above))))
+ (with-slots (master) (setf focus-dest (lookup-widget focus-dest))
+ (when (and icon-p (application-iconic-p focus-dest))
+ (uniconify (application-icon focus-dest))
+ (setf (application-wants-iconic-p focus-dest) t))
+ (when master (setf focus-dest master)))
+ (when *warp-pointer-when-cycle*
+ (xlib:warp-pointer (widget-window focus-dest) 8 5)))
+ (when (and (eq *focus-type* :on-click) *focus-when-window-cycle*)
+ (focus-widget focus-dest 0))
+ focus-dest)))
Index: eclipse/widgets.lisp
diff -u eclipse/widgets.lisp:1.15 eclipse/widgets.lisp:1.16
--- eclipse/widgets.lisp:1.15 Tue Sep 30 08:18:36 2003
+++ eclipse/widgets.lisp Mon Oct 6 13:57:26 2003
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: widgets.lisp,v 1.15 2003/09/30 12:18:36 hatchond Exp $
+;;; $Id: widgets.lisp,v 1.16 2003/10/06 17:57:26 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
@@ -54,22 +54,35 @@
(:documentation "sets the widget stacking order on top of the others."))
(defgeneric put-on-bottom (widget)
- (:documentation "sets the widget stacking order on bottom of the others
-\(except if any widget with :_net_wm_type_desktop is present and widget is or
-an application or a decoration\)."))
+ (:documentation
+ "Sets the widget stacking order on bottom of the others \(except if any
+ widget with :_net_wm_type_desktop is present and widget is or an
+ application or a decoration\)."))
(defgeneric shade (widget)
(:documentation "shade/un-shade an application that is decorated."))
(defgeneric shaded-p (widget)
- (:documentation "Return true if the widget is shaded in the sens of
-the extended window manager specification."))
+ (:documentation
+ "Returns true if the widget is shaded in the sens of the extended window
+ manager specification."))
(defgeneric root-manager (widget)
- (:documentation "Returns the root-window child that is the place holder for
- indicating that a netwm manager is present."))
-
-(defgeneric repaint (widget theme-name focus))
+ (:documentation
+ "Returns the root-window child that is the place holder for indicating that
+ a netwm manager is present."))
+
+(defgeneric repaint (widget theme-name focus)
+ (:documentation
+ "This method is dedicated to widget repaint such as every buttons, icons,
+ edges ...
+ It is specialized on widget type, theme name (via an eql specializer) and a
+ boolean that indicate if the corresponding toplevel (type decoration) is or
+ not focused.
+
+ Except for standard expose events, the repaint dispatching on focus change
+ will be perform according to parts-to-redraw-on-focus list given in
+ define-theme."))
(defmethod initialize-instance :after ((widget base-widget) &rest rest)
(declare (ignore rest))
@@ -155,12 +168,13 @@
(defconstant +properties-to-delete-on-withdrawn+
'(:_net_wm_state :_net_wm_desktop :_win_workspace))
-
+
(defclass application (base-widget)
((master :initarg :master :reader application-master)
(input-model :initform nil :initarg :input :reader application-input-model)
(icon :initform nil :initarg :icon :reader application-icon)
(iconic-p :initform nil :accessor application-iconic-p)
+ (wants-iconic-p :initform nil :accessor application-wants-iconic-p)
(wants-focus-p :initform nil :accessor application-wants-focus-p)
(initial-geometry :initform (make-geometry))
(full-geometry :initform (make-geometry))))
@@ -295,6 +309,7 @@
(pushnew :_net_wm_state_skip_pager netwm-state)
(pushnew :_net_wm_state_skip_taskbar netwm-state)
(when desktop-p
+ (pushnew :_net_wm_state_sticky netwm-state)
(add-desktop-application *root* app)
(setf (window-priority window prec-desk) stack-mode))
(setf (netwm:net-wm-state window) netwm-state
@@ -341,16 +356,20 @@
(typep widget 'button))
(declaim (inline draw-pixmap))
-(defun draw-pixmap (window gcontext pixmap)
- "Draw and tile, if necessary, the pixmap in the window."
- (multiple-value-bind (width height) (drawable-sizes window)
- (xlib:with-gcontext (gcontext :tile pixmap :fill-style :tiled)
- (xlib:draw-rectangle window gcontext 0 0 width height t))))
+(defun draw-pixmap (window gctxt pix &key (x 0) (y 0) width height)
+ "Draw, and tile if necessary, the pixmap in the given region in the window."
+ (multiple-value-bind (w h) (drawable-sizes window)
+ (unless width (setf width w))
+ (unless height (setf height h)))
+ (if (= (xlib:drawable-depth pix) 1)
+ (xlib:copy-plane pix gctxt 1 0 0 width height window x y)
+ (xlib:with-gcontext (gctxt :tile pix :fill-style :tiled :ts-x x :ts-y y)
+ (xlib:draw-rectangle window gctxt x y width height t))))
;; When calling this function arguments non optional are
;; :parent :x :y :width :height
;; the others are optional.
-(defun create-button (button-type &key parent x y width height gcontext
+(defun create-button (button-type &key parent x y width height
item background master (border-width 0)
(border *black*)
(gravity :north-west)
@@ -364,53 +383,55 @@
:background background :border border
:gravity gravity :bit-gravity (if item :north-west :forget)
:cursor cursor :event-mask event-mask)
- :gcontext gcontext
- :item-to-draw item
- :master master))
+ :item-to-draw item :master master))
;;;; Box button
;; Use it for displaying short message in window, that do not require
;; any user intervention (no OK/Cancel confirmation).
-(defclass box-button (button) ())
+(defclass box-button (button)
+ ((pixmap :initform nil :initarg :pixmap-to-display :accessor message-pixmap)))
-(defun create-message-box (messages
- &key parent (border-width 1) (background *white*))
+(defun create-message-box (messages &key parent pixmap
+ (border-width 1)
+ (background *white*))
(setf messages (apply #'concatenate 'string messages))
(let ((message-box
(create-button
'box-button
- :parent parent :event-mask '(:exposure)
+ :parent parent :event-mask '(:exposure :visibility-change)
:x 0 :y 0 :width 1 :height 1 :border-width border-width
- :background background :item messages
- :gcontext *gcontext*)))
+ :background background :item messages)))
(setf (xlib:window-override-redirect (widget-window message-box)) :on
- (button-item-to-draw message-box) messages)
+ (button-item-to-draw message-box) messages
+ (message-pixmap message-box) pixmap)
message-box))
-(defmethod (setf button-item-to-draw) (message (box box-button))
- (with-slots (window gcontext) box
+(defmethod (setf button-item-to-draw) (m (box box-button))
+ (with-slots (window (gctxt gcontext) pixmap) box
(multiple-value-bind (width height)
- (xlib:text-extents (xlib:gcontext-font gcontext) message)
- (incf width 40)
- (incf height 20)
+ (xlib:text-extents (xlib:gcontext-font gctxt) m :translate #'translate)
+ (incf width 20) (incf height 20)
+ (when pixmap
+ (setf height (max (+ 20 (xlib:drawable-height pixmap)) height))
+ (incf width (+ 10 (xlib:drawable-width pixmap))))
(multiple-value-bind (children parent) (xlib:query-tree window)
(declare (ignore children))
(let ((x (ash (- (xlib:drawable-width parent) width) -1))
(y (ash (- (xlib:drawable-height parent) height) -1)))
(setf (drawable-sizes window) (values width height)
(window-position window) (values x y)
- (slot-value box 'item-to-draw) message))))))
+ (slot-value box 'item-to-draw) m))))))
-(defmethod repaint ((widget box-button) theme-name focus)
+(defmethod repaint ((widget box-button) theme-name focus &aux x)
(declare (ignorable theme-name focus))
- (with-slots (window item-to-draw gcontext) widget
- (xlib:clear-area window)
- (multiple-value-bind (w h) (drawable-sizes window)
- (declare (type (unsigned-byte 16) w h))
- (xlib:with-gcontext (gcontext :foreground *black*)
- (xlib:draw-rectangle window gcontext 0 0 (1- w) (1- h))))
- (draw-centered-text window gcontext item-to-draw :color *black*)))
+ (with-slots (window item-to-draw gcontext pixmap) widget
+ (xlib:clear-area window)
+ (when pixmap
+ (multiple-value-bind (w h) (drawable-sizes pixmap)
+ (draw-pixmap window gcontext pixmap :x 10 :y 10 :width w :height h)
+ (setf x (+ w 20))))
+ (draw-centered-text window gcontext item-to-draw :color *black* :x x)))
;; Self destructing message box after 2 seconds.
(defun timed-message-box (window &rest messages)
@@ -549,9 +570,8 @@
(defun icon-p (widget)
(typep widget 'icon))
-(defun create-icon (application master
- &optional (gcontext *gcontext*) (bg-color *black*))
- (with-slots (window icon) application
+(defun create-icon (application master &optional (bg-color *black*))
+ (with-slots (window icon gcontext) application
(let ((background (clx-ext::wm-hints-icon-pixmap window))
(width 45) (height 20))
(if (typep background 'xlib:pixmap)
@@ -568,7 +588,6 @@
'icon
:parent *root-window* :master master
:x 0 :y 0 :width width :height height
- :gcontext gcontext
:item (unless background (wm-icon-name window))
:background (or background bg-color))
(slot-value icon 'application) application)
Index: eclipse/wm.lisp
diff -u eclipse/wm.lisp:1.20 eclipse/wm.lisp:1.21
--- eclipse/wm.lisp:1.20 Tue Sep 30 21:53:05 2003
+++ eclipse/wm.lisp Mon Oct 6 13:57:26 2003
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: wm.lisp,v 1.20 2003/10/01 01:53:05 hatchond Exp $
+;;; $Id: wm.lisp,v 1.21 2003/10/06 17:57:26 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
@@ -170,7 +170,7 @@
(eq :horizontal (style-title-bar-direction (decoration-frame-style master))))
(defun make-menu-button (master parent-window)
- (with-slots (children frame-style gcontext) master
+ (with-slots (children frame-style) master
(when (frame-item-exist-p frame-style :menu-button)
(let ((pixmaps (frame-item-pixmaps frame-style :menu-button))
(horizontal-p (title-bar-horizontal-p master)))
@@ -184,12 +184,11 @@
:item (aref pixmaps 1)
:width width :height height
:event-mask '(:owner-grab-button . #.+push-button-mask+)
- :gcontext gcontext
:y (if horizontal-p (ash (- th height) -1) (- th height))
:x (if horizontal-p 0 (ash (- tw width) -1))))))))))
(defun make-buttons-bar (master parent-window)
- (with-slots (children frame-style gcontext) master
+ (with-slots (children frame-style) master
(flet ((make-container (horizontal-p)
(xlib:create-window
:parent parent-window
@@ -211,8 +210,7 @@
:parent container :master master
:background bkgrd :item (aref pixmaps 1)
:x x :y y :width width :height height
- :event-mask +push-button-mask+
- :gcontext gcontext))
+ :event-mask +push-button-mask+))
(if horizontal-p (incf x width) (incf y height))
finally
(multiple-value-bind (w h) (drawable-sizes parent-window)
@@ -226,7 +224,7 @@
(return container))))))
(defun make-title-bar (master name)
- (with-slots (children frame-style gcontext) master
+ (with-slots (children frame-style) master
(unless (eq :none (style-title-bar-position frame-style))
(let* ((title-pos (style-title-bar-position frame-style))
(horizontal-p (case title-pos ((:top :bottom) t)))
@@ -246,7 +244,7 @@
:width 1 :height 1
:x (if horizontal-p mbw 0)
:y (if horizontal-p 0 bch)
- :gcontext gcontext :event-mask +push-button-mask+
+ :event-mask +push-button-mask+
:background (aref pixmaps 0) :item name)
(slot-value title 'parent) parent-window
(getf children :title-bar) title
@@ -267,7 +265,7 @@
(:left (values 0 top-left-h)))))
(defun make-edges (master)
- (with-slots (children window frame-style gcontext) master
+ (with-slots (children window frame-style) master
(multiple-value-bind (width height) (drawable-sizes window)
(loop for type in '(right left top bottom)
for child in '(:right :left :top :bottom)
@@ -290,10 +288,10 @@
:x x :y y
:width (pixmap-width background)
:height (pixmap-height background)
- :gcontext gcontext :cursor cursor))))))
+ :cursor cursor))))))
(defun make-corner (master width height)
- (with-slots (children window frame-style gcontext) master
+ (with-slots (children window frame-style) master
(loop for type in '(top-left top-right bottom-left bottom-right)
for gravity in '(:north-west :north-east :south-west :south-east)
for child in '(:top-left :top-right :bottom-left :bottom-right)
@@ -314,7 +312,7 @@
:x (or x (- width w))
:y (or y (- height h))
:width w :height h
- :gcontext gcontext :cursor cursor)))))
+ :cursor cursor)))))
(defun update-edges-geometry (master)
(declare (optimize (speed 3) (safety 0))
@@ -406,7 +404,6 @@
'decoration
:window window
:frame-style style
- :gcontext *gcontext*
:children (list :application application)
:application-gravity gravity
:wm-size-hints wm-sizes)))
@@ -489,17 +486,18 @@
;;;; Focus management. According to ICCCM
(defgeneric set-focus (input-model window timestamp)
- (:documentation "Set focus to the given window according to the input model.
-Input model can be :globally-active :locally-active :passive :no-input.
-For more information on the input-model sementic see ICCCM 4.1.7"))
+ (:documentation
+ "Set focus to the given window according to the input model.
+ Input model can be :globally-active :locally-active :passive :no-input.
+ For more information on the input-model sementic see ICCCM 4.1.7"))
(defmethod set-focus ((input-model (eql :globally-active)) window timestamp)
(send-wm-protocols-client-message window :wm_take_focus (or timestamp 0)))
(defmethod set-focus ((input-model (eql :locally-active)) window timestamp)
(when (eql (xlib:window-map-state window) :viewable)
- (send-wm-protocols-client-message window :wm_take_focus (or timestamp 0))
- (xlib:set-input-focus *display* window :pointer-root)))
+ (xlib:set-input-focus *display* window :pointer-root)
+ (send-wm-protocols-client-message window :wm_take_focus (or timestamp 0))))
(defmethod set-focus ((input-model (eql :passive)) window timestamp)
(declare (ignorable timestamp))
@@ -569,11 +567,11 @@
(defun make-desktop-menu (root callback-maker &key realize)
"Realize a root pop-up menu with as many entry as existing desktop. It attach
- to each entry a callback realized with the given `callback-maker' function.
- The callback-maker function should be a function of one argument of type
- integer that will be the index of the desktop entry. It may return a lambda
- or sub menu entries. If :realize is nil (the default value) it returns the
- menu entries otherwise a pop-up-menu object is return."
+ to each entry a callback realized with the given `callback-maker' function.
+ The callback-maker function should be a function of one argument of type
+ integer that will be the index of the desktop entry. It may return a lambda
+ or sub menu entries. If :realize is nil (the default value) it returns the
+ menu entries otherwise a pop-up-menu object is return."
(loop with root-window = (widget-window root)
with names = (workspace-names root-window)
for i from 0 below (number-of-virtual-screens root-window)
@@ -627,7 +625,7 @@
;; win_client_list, net_client_list(_stacking).
(defun update-lists (app state root)
"Update root properties win_client_list, net_client_list(_stacking),
- by adjoining or removing the given application depending of state."
+ by adjoining or removing the given application depending of state."
(with-slots ((appw window) iconic-p) app
(with-slots ((rw window) client-list) root
(case (if (and (= state 3) (not iconic-p)) 0 state)
@@ -676,7 +674,7 @@
(if (or (= win-workspace scr-num) stick-p)
(xlib:map-window window)
(with-event-mask (*root-window*)
- (xlib:unmap-window window))))
+ (xlib:unmap-window window))))
((or (= win-workspace scr-num) stick-p)
(decore-application window application))
(t (with-event-mask (*root-window*)
@@ -695,7 +693,8 @@
(time))
;; Sets the root window pop-up menu
- (nconc *menu-1-items* (acons "Exit" (lambda () (setf exit 1)) '()))
+ (when *menu-1-exit-p*
+ (nconc *menu-1-items* (acons "Exit" (lambda () (setf exit 1)) '())))
(with-slots (menu1 menu3) *root*
(setf menu1 (apply #'make-pop-up *root* *menu-1-items*)
menu3 (make-pop-up *root*
More information about the Eclipse-cvs
mailing list