Commit abefd73c authored by Iban Hatchondo's avatar Iban Hatchondo
Browse files

Fix: added some declaration type, and null verification so the clx patch...

Fix: added some declaration type, and null verification so the clx patch should not be necessary anymore.
Fix: wm-normal-hints returns some inproper values in fields that should be ignored. Now, we replace those obsolote fields values by the window geometry.
parent 62c79972
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: eclipse.lisp,v 1.28 2009-02-23 00:00:36 ihatchondo Exp $
;;; $Id: eclipse.lisp,v 1.29 2009-11-17 22:40:49 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2002 Iban HATCHONDO
......@@ -113,6 +113,8 @@
:override-redirect :on
:width 1 :height 1
:x 0 :y 0)))
(declare (type xlib:window manager))
(declare (type (or null xlib:window) old-wm))
(when old-wm
(setf (xlib:window-event-mask old-wm) '(:structure-notify)))
......@@ -132,8 +134,10 @@
(t nil)))
;; Are we the selection owner after all ?
(unless (xlib:window-equal manager (xlib:selection-owner display +xa-wm+))
(error "ICCCM Error: failed to aquire selection ownership~%"))
(let ((owner (xlib:selection-owner display +xa-wm+)))
(declare (type (or null xlib:window) owner))
(unless (and owner (xlib:window-equal manager owner))
(error "ICCCM Error: failed to aquire selection ownership~%")))
;; Check if a non ICCCM complient window manager is not running.
(handler-case
......
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: input.lisp,v 1.53 2009-02-20 18:03:55 ihatchondo Exp $
;;; $Id: input.lisp,v 1.54 2009-11-17 21:17:29 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
......@@ -47,7 +47,8 @@
(with-slots (window (candidat event-window)) event
(multiple-value-bind (children parent) (xlib:query-tree window)
(declare (ignore children))
(unless (xlib:window-equal candidat parent)
(declare (type (or null xlib:window) parent))
(unless (and parent (xlib:window-equal candidat parent))
(xlib:send-event parent :map-request
'(:substructure-redirect) :window window :event-window parent)))))
......
;;; -*- Mode: Lisp -*-
;;; $Id: clx-patch.lisp,v 1.6 2004-03-03 09:05:12 ihatchondo Exp $
;;; $Id: clx-patch.lisp,v 1.7 2009-11-17 17:29:13 ihatchondo Exp $
;;;
;;; This file contains the patch fixing a bug in CLX as distributed
;;; with vanilla CMUCL versions up to 18d.
......@@ -56,27 +56,27 @@ Indeed O or 1 are inappropriated ID's.
;; one is not of the proper type but this should save us from lots of
;; testing.
(macrolet ((make-mumble-equal (type)
;; Since caching is only done for objects created by the
;; client, we must always compare ID and display for
;; non-identical mumbles.
(let ((predicate (xintern type '-equal))
(id (xintern type '-id))
(dpy (xintern type '-display)))
`(within-definition (,type make-mumble-equal)
(defun ,predicate (a b)
(declare (type (or null ,type) a b))
(when (and a b)
(or (eql a b)
(and (= (,id a) (,id b))
(eq (,dpy a) (,dpy b))))))))))
(make-mumble-equal window)
(make-mumble-equal pixmap)
(make-mumble-equal cursor)
(make-mumble-equal font)
(make-mumble-equal gcontext)
(make-mumble-equal colormap)
(make-mumble-equal drawable))
;; (macrolet ((make-mumble-equal (type)
;; ;; Since caching is only done for objects created by the
;; ;; client, we must always compare ID and display for
;; ;; non-identical mumbles.
;; (let ((predicate (xintern type '-equal))
;; (id (xintern type '-id))
;; (dpy (xintern type '-display)))
;; `(within-definition (,type make-mumble-equal)
;; (defun ,predicate (a b)
;; (declare (type (or null ,type) a b))
;; (when (and a b)
;; (or (eql a b)
;; (and (= (,id a) (,id b))
;; (eq (,dpy a) (,dpy b))))))))))
;; (make-mumble-equal window)
;; (make-mumble-equal pixmap)
;; (make-mumble-equal cursor)
;; (make-mumble-equal font)
;; (make-mumble-equal gcontext)
;; (make-mumble-equal colormap)
;; (make-mumble-equal drawable))
;; It seems that sometimes some id are still present in the clx display
;; internal cache even when those resources have been destroyed. This has
......
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: misc.lisp,v 1.46 2009-11-17 17:30:00 ihatchondo Exp $
;;; $Id: misc.lisp,v 1.47 2009-11-17 22:40:49 ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2002 Iban HATCHONDO
......@@ -110,6 +110,18 @@
(or (xlib:transient-for app-window)
(member :_net_wm_window_type_dialog (netwm:net-wm-state app-window))))
(defun wm-normal-hints (window)
"Returns the window WM_NORMAL_HINTS property with the obsolete values
reset to the window geometry."
(let ((hint (ignore-errors (xlib:wm-normal-hints window))))
(unless (null hint)
(multiple-value-bind (x y w h) (window-geometry window)
(setf (xlib:wm-size-hints-x hint) x
(xlib:wm-size-hints-y hint) y
(xlib:wm-size-hints-width hint) w
(xlib:wm-size-hints-height hint) h)))
hint))
(defun wm-state (window)
"Returns the wm_state property of a window as xlib:get-property would."
(xlib:get-property window :WM_STATE))
......@@ -247,6 +259,9 @@
(flet ((lookup-app-w (widget)
(when (decoration-p widget)
(get-child widget :application :window t)))
(layer-member (window windows)
(when (xlib:window-p window)
(member window windows :test #'xlib:window-equal)))
(first-win (windows &optional above-p)
(car (if above-p (last windows) windows)))
(restack (app sib-app priority)
......@@ -254,7 +269,7 @@
(let* ((window (widget-window (or (application-master app) app)))
(sm (when sib-app (application-master sib-app)))
(sibling (when sib-app (widget-window (or sm sib-app)))))
(unless (xlib:window-equal window sibling)
(unless (and sibling (xlib:window-equal window sibling))
(setf (xlib:window-priority window sibling) priority))))))
(let* ((win (or (lookup-app-w (lookup-widget window)) window))
(sib (or (lookup-app-w (lookup-widget sibling)) sibling))
......@@ -272,20 +287,20 @@
(setf wnwm-state (nconc wnwm-state (netwm:net-wm-state lw)))))
;; Find the correct sibling and reset the priority if needed.
(cond ((member :_net_wm_state_below wnwm-state)
(unless (member sib below-layer :test #'xlib:window-equal)
(unless (layer-member sib below-layer)
(setf sib (first-win (or below-layer std-layer above-layer)
(and below-layer above-p)))
(and below-layer above-p)))
(unless below-layer (setf stack-mode :below))))
((member :_net_wm_state_above wnwm-state)
(unless (member sib above-layer :test #'xlib:window-equal)
(unless (layer-member sib above-layer)
(unless (member :_net_wm_state_fullscreen snwm-state)
(setf sib (first-win above-layer above-p))
(unless above-layer (setf stack-mode :above)))))
((member :_net_wm_state_fullscreen wnwm-state)
(when (member sib below-layer :test #'xlib:window-equal)
(when (layer-member sib below-layer)
(setf sib (first-win (or std-layer above-layer)))
(setf stack-mode :below)))
((not (member sib std-layer :test #'xlib:window-equal))
((not (layer-member sib std-layer))
(setf sib (first-win (or std-layer below-layer above-layer)
(if std-layer above-p below-layer)))
(unless std-layer
......@@ -348,7 +363,7 @@
(parent (when master (widget-window master)))
(top-margin 0) (left-margin 0)
(g (or gravity (and master (decoration-application-gravity master))
(let ((h (ignore-errors (xlib:wm-normal-hints win))))
(let ((h (ignore-errors (wm-normal-hints win))))
(if h (xlib:wm-size-hints-win-gravity h) :north-west)))))
(when master
(setf top-margin (style-top-margin (decoration-frame-style master)))
......
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: widgets.lisp,v 1.58 2009-11-17 17:33:21 ihatchondo Exp $
;;; $Id: widgets.lisp,v 1.59 2009-11-17 21:17:29 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
......@@ -296,7 +296,7 @@
(defun fullscreenable-p (application)
(with-slots (window) application
(let ((hint (ignore-errors (xlib:wm-normal-hints window))))
(let ((hint (ignore-errors (wm-normal-hints window))))
(symbol-macrolet ((max-h (and hint (xlib:wm-size-hints-max-height hint)))
(max-w (and hint (xlib:wm-size-hints-max-width hint))))
(and (if max-w (= max-w (screen-width)) t)
......@@ -515,7 +515,7 @@
actual geometry of the specified window. If the optional geometry is
given then it will be filled and returned."
(multiple-value-bind (x y w h) (window-geometry window)
(let ((hint (ignore-errors (xlib:wm-normal-hints window))))
(let ((hint (ignore-errors (wm-normal-hints window))))
(setf (geometry geometry)
(values (or (when hint (xlib:wm-size-hints-x hint)) x)
(or (when hint (xlib:wm-size-hints-y hint)) y)
......
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: wm.lisp,v 1.59 2009-11-17 21:17:29 ihatchondo Exp $
;;; $Id: wm.lisp,v 1.60 2009-11-17 21:36:08 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
......@@ -169,7 +169,7 @@
the window gravity of the designed window. The wm-normal-hints property is
recomputed in order to reflect the margin that a top level decoration widget
(aka master) might introduce."
(let ((hints (or (ignore-errors (xlib:wm-normal-hints window))
(let ((hints (or (ignore-errors (wm-normal-hints window))
(xlib:make-wm-size-hints)))
(max-ww (screen-width))
(max-hh (screen-height)))
......@@ -364,7 +364,7 @@
(defun initial-coordinates (window frame-style)
"Returns as multiple values the decoration initial coordinates."
(let ((hint (ignore-errors (xlib:wm-normal-hints window))))
(let ((hint (ignore-errors (wm-normal-hints window))))
(with-slots (top-margin left-margin vmargin hmargin) frame-style
(flet ((default-coordinates ()
(let* ((n (or (window-desktop-num window) 0))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment