Update of /project/eclipse/cvsroot/eclipse In directory common-lisp.net:/tmp/cvs-serv6546 Modified Files: gestures.lisp input.lisp misc.lisp package.lisp widgets.lisp wm.lisp Log Message: add support for icon as described in the exwm spec. - decode-netwm-icon-pixmap (misc.lisp) - small impacts in gestures.lisp & widgets.lisp. add a new callback on the application list root menu: when no window on a desktop then releasing the mouse button on such an entry will put you on that desktop. (wm.lisp) package.lisp updated. Date: Fri Nov 28 05:13:48 2003 Author: ihatchondo Index: eclipse/gestures.lisp diff -u eclipse/gestures.lisp:1.11 eclipse/gestures.lisp:1.12 --- eclipse/gestures.lisp:1.11 Wed Nov 19 05:29:08 2003 +++ eclipse/gestures.lisp Fri Nov 28 05:13:47 2003 @@ -1,5 +1,5 @@ ;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*- -;;; $Id: gestures.lisp,v 1.11 2003/11/19 10:29:08 ihatchondo Exp $ +;;; $Id: gestures.lisp,v 1.12 2003/11/28 10:13:47 ihatchondo Exp $ ;;; ;;; ECLIPSE. The Common Lisp Window Manager. ;;; Copyright (C) 2002 Iban HATCHONDO @@ -255,7 +255,7 @@ (default-modifiers-p t) (modifiers :any) fun) -" modifiers can be: + " modifiers can be: - composition of modifiers as '(:and :ALT-LEFT :CONTROL-RIGHT) - a simple modifier as :ALT-LEFT or 18 (a modifier mask) - a list of possible modifiers as '(:ALT-LEFT :CONTOL-RIGHT)" @@ -276,7 +276,7 @@ (default-modifiers-p t) (modifiers :any) fun) -" modifiers can be: + " modifiers can be: - composition of modifiers as '(:and :ALT-LEFT :CONTROL-RIGHT) - a simple modifier as :ALT-LEFT or 18 (a modifier mask) - a list of possible modifiers as '(:ALT-LEFT :CONTOL-RIGHT)" @@ -386,9 +386,10 @@ (when (eq direction :below) (incf depth-aux)) (rotatef (nth 0 *windows*) (nth depth-aux *windows*))))) (when (and *verbose-window-cycling* (car *windows*)) - (with-slots (window) (lookup-widget (car *windows*)) + (with-slots (window icon) (lookup-widget (car *windows*)) (setf (message-pixmap *current-widget-info*) - (clx-ext::wm-hints-icon-pixmap window)) + (or (icon-pixmap-to-free icon) + (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) Index: eclipse/input.lisp diff -u eclipse/input.lisp:1.23 eclipse/input.lisp:1.24 --- eclipse/input.lisp:1.23 Mon Nov 24 08:44:50 2003 +++ eclipse/input.lisp Fri Nov 28 05:13:47 2003 @@ -1,5 +1,5 @@ ;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*- -;;; $Id: input.lisp,v 1.23 2003/11/24 13:44:50 ihatchondo Exp $ +;;; $Id: input.lisp,v 1.24 2003/11/28 10:13:47 ihatchondo Exp $ ;;; ;;; ECLIPSE. The Common Lisp Window Manager. ;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO @@ -374,16 +374,16 @@ (let* ((cur-desk (window-desktop-num window)) (new-desk (aref data 0)) (master-window (and master (widget-window master))) - (unmap-p (/= new-desk +any-desktop+ (current-desk)))) + (unmap-p (/= new-desk +any-desktop+ (current-desk))) + (operation (if unmap-p #'xlib:unmap-window #'xlib:map-window))) (unless (= cur-desk new-desk) (when (shaded-p application) (shade application)) (setf (window-desktop-num window) new-desk) - (let ((operation (if unmap-p #'xlib:unmap-window #'xlib:map-window))) - (with-event-mask (*root-window*) - (funcall operation (or master-window window)) - (when master-window - (with-event-mask (master-window) - (funcall operation window))))) + (with-event-mask (*root-window*) + (funcall operation (or master-window window)) + (when master-window + (with-event-mask (master-window) + (funcall operation window)))) (when unmap-p (xlib:set-input-focus *display* :pointer-root :pointer-root))))) (:_NET_CLOSE_WINDOW (close-widget application)) @@ -488,4 +488,4 @@ ;;; Events for Message Box (defmethod event-process ((event visibility-notify) (box box-button)) - (setf (xlib:window-priority (widget-window box)) :above)) \ No newline at end of file + (setf (xlib:window-priority (widget-window box)) :above)) Index: eclipse/misc.lisp diff -u eclipse/misc.lisp:1.14 eclipse/misc.lisp:1.15 --- eclipse/misc.lisp:1.14 Wed Nov 19 05:29:08 2003 +++ eclipse/misc.lisp Fri Nov 28 05:13:47 2003 @@ -1,5 +1,5 @@ ;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*- -;;; $Id: misc.lisp,v 1.14 2003/11/19 10:29:08 ihatchondo Exp $ +;;; $Id: misc.lisp,v 1.15 2003/11/28 10:13:47 ihatchondo Exp $ ;;; ;;; This file is part of Eclipse. ;;; Copyright (C) 2002 Iban HATCHONDO @@ -29,7 +29,6 @@ "~/")) directory)) - ;;;; Helpers macros. (defmacro with-gensym (symbols &body body) @@ -115,6 +114,32 @@ (or (ignore-errors (netwm:net-wm-icon-name window)) (ignore-errors (xlib:wm-icon-name window)) "incognito")) + +(defun decode-netwm-icon-pixmap (window property-vector) + "Return a pixmap containing the first icon of the property or NIL." + ;;(declare (optimize (speed 3) (safety 1))) + (declare (type (or null (simple-vector *)) property-vector)) + (unless property-vector (return-from decode-netwm-icon-pixmap nil)) + (loop with depth of-type ppm::card-8 = (xlib:drawable-depth window) + with bits-per-pixel = (ppm::find-bits-per-pixel depth) + with type = `(unsigned-byte ,depth) + with width of-type ppm::card-16 = (aref property-vector 0) + with height of-type ppm::card-16 = (aref property-vector 1) + with size of-type ppm::card-32 = (* width height) + with data = (make-array (list height width) :element-type type) + with tmp = (make-array size :displaced-to data :element-type type) + for i of-type ppm::card-32 from 2 below (+ 2 size) + for argb of-type ppm::card-32 = (aref property-vector i) + for r of-type ppm::card-8 = (ldb (byte 8 16) argb) + for g of-type ppm::card-8 = (ldb (byte 8 8) argb) + for b of-type ppm::card-8 = (ldb (byte 8 0) argb) + do (setf (aref tmp (- i 2)) (ppm::get-color r g b)) + finally (return + (xlib:image-pixmap + window + (xlib:create-image + :width width :height height :depth depth + :bits-per-pixel bits-per-pixel :data data))))) (defun window-desktop-num (window) (or (netwm:net-wm-desktop window) (gnome:win-workspace window))) Index: eclipse/package.lisp diff -u eclipse/package.lisp:1.11 eclipse/package.lisp:1.12 --- eclipse/package.lisp:1.11 Mon Nov 24 11:57:46 2003 +++ eclipse/package.lisp Fri Nov 28 05:13:47 2003 @@ -1,5 +1,5 @@ ;;; -*- Mode: Lisp; Package: User -*- -;;; $Id: package.lisp,v 1.11 2003/11/24 16:57:46 ihatchondo Exp $ +;;; $Id: package.lisp,v 1.12 2003/11/28 10:13:47 ihatchondo Exp $ ;;; ;;; This file is part of Eclipse. ;;; Copyright (C) 2002 Iban HATCHONDO @@ -80,6 +80,7 @@ "CREATE-ICON" ;function "CREATE-MESSAGE-BOX" ;function "CURRENT-VSCREEN" ;function + "DECODE-NETWM-ICON-PIXMAP" ;function "DECORATION-P" ;function "DECORATION-THEME" ;setf function "DECORE-APPLICATION" ;function Index: eclipse/widgets.lisp diff -u eclipse/widgets.lisp:1.20 eclipse/widgets.lisp:1.21 --- eclipse/widgets.lisp:1.20 Mon Nov 24 08:12:02 2003 +++ eclipse/widgets.lisp Fri Nov 28 05:13:47 2003 @@ -1,5 +1,5 @@ ;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*- -;;; $Id: widgets.lisp,v 1.20 2003/11/24 13:12:02 ihatchondo Exp $ +;;; $Id: widgets.lisp,v 1.21 2003/11/28 10:13:47 ihatchondo Exp $ ;;; ;;; ECLIPSE. The Common Lisp Window Manager. ;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO @@ -557,33 +557,37 @@ (defclass icon (push-button) ((desiconify-p :initform nil :accessor icon-desiconify-p) (creation-time :initform (get-universal-time) :accessor icon-creation-time) - (application :initarg :application :reader icon-application))) + (application :initarg :application :reader icon-application) + (pixmap-to-free :initform nil :reader icon-pixmap-to-free))) (defun icon-p (widget) (typep widget 'icon)) (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)) + (let* ((bkgrd (decode-netwm-icon-pixmap window (netwm:net-wm-icon window))) + (width 45) (height 20) (pixmap-to-free bkgrd)) + (unless bkgrd + (setf bkgrd (ignore-errors (clx-ext::wm-hints-icon-pixmap window)))) (ignore-errors - (if (typep background 'xlib:pixmap) - (multiple-value-setq (width height) (drawable-sizes background)) - (setf background nil))) + (if (typep bkgrd 'xlib:pixmap) + (multiple-value-setq (width height) (drawable-sizes bkgrd)) + (setf bkgrd nil))) (ignore-errors - (when (and background (= 1 (xlib:drawable-depth background))) + (when (and bkgrd (= 1 (xlib:drawable-depth bkgrd))) (let ((pix (xlib:create-pixmap :drawable window :width width :height height :depth (xlib:drawable-depth window)))) - (xlib:copy-plane background gcontext 1 0 0 width height pix 0 0) - (setf background pix)))) + (xlib:copy-plane bkgrd gcontext 1 0 0 width height pix 0 0) + (setf bkgrd pix)))) (setf icon (create-button 'icon :parent *root-window* :master master :x 0 :y 0 :width width :height height - :item (unless background (wm-icon-name window)) - :background (or background bg-color)) - (slot-value icon 'application) application) + :item (unless bkgrd (wm-icon-name window)) + :background (or bkgrd bg-color))) + (setf (slot-value icon 'pixmap-to-free) pixmap-to-free) + (setf (slot-value icon 'application) application) icon))) (defun icon-sort-creation-order (icon1 icon2) @@ -651,6 +655,11 @@ (xlib:with-state (icon-window) (setf (window-position icon-window) (values basex basey))))) (setq prev-icon-window icon-window))))))) + +(defmethod remove-widget :after ((widget icon)) + (with-slots (pixmap-to-free) widget + (when pixmap-to-free + (xlib:free-pixmap pixmap-to-free)))) (defmethod repaint ((widget icon) theme-name focus) (declare (ignorable theme-name focus)) Index: eclipse/wm.lisp diff -u eclipse/wm.lisp:1.24 eclipse/wm.lisp:1.25 --- eclipse/wm.lisp:1.24 Mon Nov 24 11:57:46 2003 +++ eclipse/wm.lisp Fri Nov 28 05:13:47 2003 @@ -1,5 +1,5 @@ ;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*- -;;; $Id: wm.lisp,v 1.24 2003/11/24 16:57:46 ihatchondo Exp $ +;;; $Id: wm.lisp,v 1.25 2003/11/28 10:13:47 ihatchondo Exp $ ;;; ;;; ECLIPSE. The Common Lisp Window Manager. ;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO @@ -592,11 +592,13 @@ (1 (change-vscreen root :n index)) (3 (uniconify (slot-value (lookup-widget window) 'icon)))) (put-on-top (lookup-widget window)))) - (make-desktop-entries (index) - (loop for w in (screen-content index :iconify-p t) + (make-desktop-entries (i) + (loop for w in (screen-content i :iconify-p t) for state = (= 1 (first (wm-state w))) - collect (cons (format nil "~:[[ ~A ]~;~A~]" state (wm-name w)) - (raise w index))))) + for name = (format nil "~:[[ ~A ]~;~A~]" state (wm-name w)) + collect (cons name (raise w i)) into entries + finally + (return (or entries (lambda () (change-vscreen root :n i))))))) (make-desktop-menu root #'make-desktop-entries :realize t))) (defun make-menu-button-menu (master)