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)
