[Eclipse-cvs] CVS eclipse
ihatchondo
ihatchondo at common-lisp.net
Fri Apr 25 16:02:49 UTC 2008
Update of /project/eclipse/cvsroot/eclipse
In directory clnet:/tmp/cvs-serv19826
Modified Files:
eclipse.lisp global.lisp input.lisp misc.lisp move-resize.lisp
widgets.lisp wm.lisp
Log Message:
Fix: hacking around *root-window* ...
--- /project/eclipse/cvsroot/eclipse/eclipse.lisp 2007/05/08 22:33:17 1.26
+++ /project/eclipse/cvsroot/eclipse/eclipse.lisp 2008/04/25 16:02:49 1.27
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: eclipse.lisp,v 1.26 2007/05/08 22:33:17 ihatchondo Exp $
+;;; $Id: eclipse.lisp,v 1.27 2008/04/25 16:02:49 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2002 Iban HATCHONDO
@@ -129,7 +129,7 @@
(let ((first-desknum (current-vscreen window))
(nb-vs (number-of-virtual-screens window))
(srcw (screen-width)) (srch (screen-height)))
- (xlib:with-server-grabbed (*display*)
+ (xlib:with-server-grabbed (display)
(delete-properties window +netwm-protocol+)
(unless (< -1 first-desknum nb-vs) (setf first-desknum 0))
(setf (gnome:win-protocols window) +gnome-protocols+
@@ -166,7 +166,7 @@
(xlib:display-after-function display) #'xlib:display-force-output)
(setf *root* (make-instance 'root :window root-window :manager manager)
*root-window* root-window
- (root-default-cursor *root*) (get-x-cursor *display* :xc_left_ptr)
+ (root-default-cursor *root*) (get-x-cursor display :xc_left_ptr)
(root-sm-conn *root*) (connect-to-session-manager
display-specification sm-client-id))
;; init all gnome properties on root.
@@ -177,7 +177,7 @@
*white* (xlib:screen-white-pixel screen)
*background1* (xlib:alloc-color colormap *menu-color*)
*background2* (xlib:alloc-color colormap *menu-hilighted-color*)
- *cursor-2* (get-x-cursor *display* :xc_fleur)
+ *cursor-2* (get-x-cursor display :xc_fleur)
*gctxt* (xlib:create-gcontext :drawable root-window :font menu-font)
*max-char-width* (xlib:max-char-width menu-font)
*gcontext* (xlib:create-gcontext
--- /project/eclipse/cvsroot/eclipse/global.lisp 2008/04/23 09:54:46 1.30
+++ /project/eclipse/cvsroot/eclipse/global.lisp 2008/04/25 16:02:49 1.31
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: global.lisp,v 1.30 2008/04/23 09:54:46 ihatchondo Exp $
+;;; $Id: global.lisp,v 1.31 2008/04/25 16:02:49 ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2001, 2002 Iban HATCHONDO
@@ -119,17 +119,20 @@
(defsetf decoration-theme (&key free-old-theme-p) (name)
"Sets the theme that must be used for window decoration. This theme will
be used for all existing applications as well as futur one."
- `(with-slots (decoration-theme) *root*
- (let ((theme (load-theme *root-window* ,name)))
- (when decoration-theme
- (loop with old-name = (theme-name decoration-theme)
- for val being each hash-value in *widget-table*
- when (and (application-p val) (application-master val)) do
- (with-slots (window master) val
+ `(set-decoration-theme ,name ,free-old-theme-p))
+
+(defun set-decoration-theme (name free-old-theme-p)
+ (with-slots (decoration-theme window) *root*
+ (let ((theme (load-theme window name)))
+ (when decoration-theme
+ (loop with old-name = (theme-name decoration-theme)
+ for val being each hash-value in *widget-table*
+ when (and (application-p val) (application-master val)) do
+ (with-slots (window master) val
(setf (decoration-frame-style master)
(find-decoration-frame-style theme window)))
- finally (and ,free-old-theme-p (free-theme old-name))))
- (setf decoration-theme theme))))
+ finally (and free-old-theme-p (free-theme old-name))))
+ (setf decoration-theme theme))))
(defsetf maximize-modifier () (modifier-key)
"Sets the modifier to use to activate window maximization second behavior."
--- /project/eclipse/cvsroot/eclipse/input.lisp 2008/04/23 09:54:46 1.48
+++ /project/eclipse/cvsroot/eclipse/input.lisp 2008/04/25 16:02:49 1.49
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: input.lisp,v 1.48 2008/04/23 09:54:46 ihatchondo Exp $
+;;; $Id: input.lisp,v 1.49 2008/04/25 16:02:49 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
@@ -90,7 +90,8 @@
(when (or (decoration-p widget) (application-p (lookup-widget window)))
(if (eq *focus-type* :on-click)
(give-focus-to-next-widget-in-desktop)
- (multiple-value-bind (x y s child) (xlib:query-pointer *root-window*)
+ (multiple-value-bind (x y s child)
+ (xlib:query-pointer (xlib:drawable-root window))
(declare (ignore x y s))
(let ((e (make-event :enter-notify :kind :nonlinear :mode :normal)))
(event-process e (or (lookup-widget child) *root*))))))))
@@ -316,7 +317,7 @@
(with-slots (master window) application
(unless (eql (event-mode event) :grab)
(when master (dispatch-repaint master :focus t))
- (setf (netwm:net-active-window *root-window*) window)
+ (setf (netwm:net-active-window (xlib:drawable-root window)) window)
(xlib:delete-property
(widget-window (root-property-holder *root*))
:_net_active_window))))
--- /project/eclipse/cvsroot/eclipse/misc.lisp 2008/04/23 09:54:46 1.41
+++ /project/eclipse/cvsroot/eclipse/misc.lisp 2008/04/25 16:02:49 1.42
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: misc.lisp,v 1.41 2008/04/23 09:54:46 ihatchondo Exp $
+;;; $Id: misc.lisp,v 1.42 2008/04/25 16:02:49 ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2002 Iban HATCHONDO
@@ -91,14 +91,16 @@
(defsetf wm-state (window &key (icon-id 0)) (state)
"Sets the wm_state property of a window. Note that its _net_wm_state property
will be updated accordingly to the value given for the wm_state."
- (let ((net-wm-state (gensym)))
- `(let ((,net-wm-state (netwm:net-wm-state ,window)))
- (if (or (= ,state 3) (= ,state 0))
- (pushnew :_net_wm_state_hidden ,net-wm-state)
- (setf ,net-wm-state (delete :_net_wm_state_hidden ,net-wm-state)))
- (setf (netwm:net-wm-state ,window) ,net-wm-state)
- (xlib:change-property ,window :WM_STATE
- (list ,state ,icon-id)
+ (with-gensym (_window _state _net-wm-state)
+ `(let* ((,_window ,window)
+ (,_state ,state)
+ (,_net-wm-state (netwm:net-wm-state ,_window)))
+ (if (or (= ,_state 3) (= ,_state 0))
+ (pushnew :_net_wm_state_hidden ,_net-wm-state)
+ (setf ,_net-wm-state (delete :_net_wm_state_hidden ,_net-wm-state)))
+ (setf (netwm:net-wm-state ,_window) ,_net-wm-state)
+ (xlib:change-property ,_window :WM_STATE
+ (list ,_state ,icon-id)
:WM_STATE
32))))
@@ -107,12 +109,12 @@
between _net_wm_desktop_names and _win_workspace_names respectively."
(or (netwm:net-desktop-names window) (gnome:win-workspace-names window)))
-(defsetf workspace-names () (names)
+(defsetf workspace-names (window) (names)
"Sets both the _win_workspace_names and the _net_wm_desktop_names properties
to the given list of name."
`(when ,names
- (setf (netwm:net-desktop-names *root-window*) ,names
- (gnome:win-workspace-names *root-window*) ,names)))
+ (setf (netwm:net-desktop-names ,window) ,names
+ (gnome:win-workspace-names ,window) ,names)))
(defun wm-name (window)
"Returns the name of the window according to the first property that is set
--- /project/eclipse/cvsroot/eclipse/move-resize.lisp 2005/01/17 09:30:40 1.18
+++ /project/eclipse/cvsroot/eclipse/move-resize.lisp 2008/04/25 16:02:49 1.19
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: move-resize.lisp,v 1.18 2005/01/17 09:30:40 ihatchondo Exp $
+;;; $Id: move-resize.lisp,v 1.19 2008/04/25 16:02:49 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
@@ -31,9 +31,9 @@
(when *geometry-info-box*
(xlib:unmap-window (widget-window *geometry-info-box*))))
-(defun initialize-geometry-info-box ()
+(defun initialize-geometry-info-box (parent-window)
(unless *geometry-info-box*
- (setf *geometry-info-box* (create-message-box nil :parent *root-window*)))
+ (setf *geometry-info-box* (create-message-box nil :parent parent-window)))
(with-slots (window) *geometry-info-box*
(xlib:map-window window)
(setf (xlib:window-priority window) :above)))
@@ -59,9 +59,9 @@
(defparameter *clone* nil)
-(defun initialize-clone ()
+(defun initialize-clone (parent-window)
(let ((win (xlib:create-window
- :parent *root-window* :x 0 :y 0 :width 100 :height 100)))
+ :parent parent-window :x 0 :y 0 :width 100 :height 100)))
(setf *clone* (make-decoration win (create-application win nil)))))
(defun update-*clone* (x y w h decoration-frame-style &optional wm-hints)
@@ -96,13 +96,13 @@
(with-slots (resize-status move-status current-active-widget window) root
(with-slots ((widget-window window) gcontext active-p) widget
(when (and active-p (not (or resize-status move-status)))
- (or *clone* (initialize-clone))
+ (or *clone* (initialize-clone window))
(update-clone widget)
(grab-root-pointer)
(setf (slot-value root status) t
current-active-widget widget)
(when verbose-p
- (initialize-geometry-info-box)
+ (initialize-geometry-info-box window)
(multiple-value-bind (x y w h) (window-geometry widget-window)
(if (and (eq status 'resize-status) (decoration-p widget))
(multiple-value-bind (a b c d iw ih bw bh)
@@ -255,7 +255,8 @@
;; called when button-release on root and root-resize-status is not nil.
(with-slots (window gcontext) master
(when (and (decoration-active-p master) (eql mode :box))
- (draw-window-grid (widget-window *clone*) gcontext *root-window*)
+ (draw-window-grid
+ (widget-window *clone*) gcontext (xlib:drawable-root window))
(multiple-value-bind (x y w h)
(window-geometry (widget-window *clone*))
(setf (window-position window) (values x y)
@@ -296,9 +297,10 @@
(update-edges-geometry master)
(resize-from master))
(with-slots (window gcontext) *clone*
- (draw-window-grid window gcontext *root-window*)
- (resize-internal *clone* event verbose-p)
- (draw-window-grid window gcontext *root-window*))))
+ (let ((root-window (xlib:drawable-root window)))
+ (draw-window-grid window gcontext root-window)
+ (resize-internal *clone* event verbose-p)
+ (draw-window-grid window gcontext root-window)))))
;;;; Move.
@@ -403,10 +405,11 @@
(when verbose-p (display-coordinates new-x new-y))
(if (and (or (decoration-p widget) (application-p widget))
(eql mode :box))
- (with-slots (window) *clone*
- (draw-window-grid window gcontext *root-window*)
- (setf (window-position window) (values new-x new-y))
- (draw-window-grid window gcontext *root-window*))
+ (with-slots (window) *clone*
+ (let ((root-window (xlib:drawable-root window)))
+ (draw-window-grid window gcontext root-window)
+ (setf (window-position window) (values new-x new-y))
+ (draw-window-grid window gcontext root-window)))
(setf (window-position window) (values new-x new-y)))))))
(defun finish-move (widget &optional verbose-p mode)
@@ -414,7 +417,7 @@
(with-slots ((widget-window window) active-p) widget
(when (eql mode :box)
(with-slots (window gcontext) *clone*
- (draw-window-grid window gcontext *root-window*)
+ (draw-window-grid window gcontext (xlib:drawable-root window))
(setf (window-position widget-window) (window-position window))))
(setf active-p nil)
(when verbose-p (undraw-geometry-info-box)))
--- /project/eclipse/cvsroot/eclipse/widgets.lisp 2008/04/25 08:42:44 1.54
+++ /project/eclipse/cvsroot/eclipse/widgets.lisp 2008/04/25 16:02:49 1.55
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: widgets.lisp,v 1.54 2008/04/25 08:42:44 ihatchondo Exp $
+;;; $Id: widgets.lisp,v 1.55 2008/04/25 16:02:49 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
@@ -400,7 +400,7 @@
(setf (netwm:net-wm-state window) prop))
(if (eq mode :on)
;; put in fullscreen mode.
- (with-event-mask (*root-window*)
+ (with-event-mask ((xlib:drawable-root window))
(multiple-value-bind (x y w h) (window-geometry window)
(when master
(with-slots (children (master-win window) frame-style) master
@@ -414,7 +414,7 @@
(configure-window window :x x :y y :width w :height h))
(focus-widget application 0))
;; revert: restore precedent geometry and decoration style.
- (with-event-mask (*root-window*)
+ (with-event-mask ((xlib:drawable-root window))
(setf (drawable-sizes window) (geometry-sizes fgeometry))
(unless (window-not-decorable-p window)
(setf (decoration-frame-style master)
@@ -440,7 +440,7 @@
(with-slots (master window) application
(when (shaded-p application) (shade application))
(setf (window-desktop-num window) new-screen-number)
- (with-event-mask (*root-window*)
+ (with-event-mask ((xlib:drawable-root window))
(let ((master-window (when master (widget-window master))))
(funcall operation (or master-window window))
(when master-window
@@ -457,10 +457,11 @@
"Removes all decoration of this application widget and reparent it to root."
(with-slots (window master icon) application
(if master
- (multiple-value-bind (x y)
- (xlib:translate-coordinates window 0 0 *root-window*)
- (xlib:reparent-window window *root-window* x y)
- (event-process (make-event :destroy-notify) master))
+ (let ((root-window (xlib:drawable-root window)))
+ (multiple-value-bind (x y)
+ (xlib:translate-coordinates window 0 0 root-window)
+ (xlib:reparent-window window root-window x y)
+ (event-process (make-event :destroy-notify) master)))
(event-process (make-event :destroy-notify :window window) *root*))
(when state
(setf (wm-state window) state)
@@ -823,7 +824,7 @@
(setf bkgrd pix))))
(setf icon (create-button 'icon
:event-mask '(:pointer-motion-hint . #.+std-button-mask+)
- :parent *root-window* :master master
+ :parent (xlib:drawable-root window) :master master
:x 0 :y 0 :width width :height height
:item (unless bkgrd (wm-icon-name window))
:background (or bkgrd bg-color)))
--- /project/eclipse/cvsroot/eclipse/wm.lisp 2008/04/25 08:42:45 1.54
+++ /project/eclipse/cvsroot/eclipse/wm.lisp 2008/04/25 16:02:49 1.55
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: wm.lisp,v 1.54 2008/04/25 08:42:45 ihatchondo Exp $
+;;; $Id: wm.lisp,v 1.55 2008/04/25 16:02:49 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
@@ -362,16 +362,16 @@
(setf (drawable-sizes window)
(values (max 1 (- width hm)) (max 1 (- height vm))))))))
-(defun initial-coordinates (app-window frame-style)
+(defun initial-coordinates (window frame-style)
"Returns as multiple values the decoration initial coordinates."
- (let ((hint (ignore-errors (xlib:wm-normal-hints app-window))))
+ (let ((hint (ignore-errors (xlib:wm-normal-hints window))))
(with-slots (top-margin left-margin vmargin hmargin) frame-style
(flet ((default-coordinates ()
- (let* ((n (or (window-desktop-num app-window) 0))
+ (let* ((n (or (window-desktop-num window) 0))
(k (if (= +any-desktop+ n) 0 (* 4 n)))
- (areas (netwm:net-workarea *root-window*))
+ (areas (netwm:net-workarea (xlib:drawable-root window)))
(ax (aref areas k)) (ay (aref areas (1+ k))))
- (multiple-value-bind (x y) (window-position app-window)
+ (multiple-value-bind (x y) (window-position window)
(values (max ax (- x left-margin))
(max ay (- y top-margin)))))))
(if (and hint (xlib:wm-size-hints-user-specified-position-p hint))
More information about the Eclipse-cvs
mailing list