Update of /project/eclipse/cvsroot/eclipse
In directory cl-net:/tmp/cvs-serv12329
Modified Files:
.eclipse input.lisp package.lisp themer.lisp widgets.lisp
wm.lisp
Log Message:
Fix: theme rework to remove eql specializer on theme name in favor of theme object.
--- /project/eclipse/cvsroot/eclipse/.eclipse 2003/08/28 14:51:37 1.5
+++ /project/eclipse/cvsroot/eclipse/.eclipse 2009/11/17 21:17:29 1.6
@@ -58,7 +58,7 @@
:modifiers '(:and :ALT-LEFT :CONTROL-LEFT))
(define-key-combo :scroll-down
:keys '(:q)
- :modifiers '(:and :ALT-LEFT :CONTROL-LEFT))
+ :modifiers '(:and :ISO-LEVEL3-SHIFT :CONTROL-LEFT))
;; example of user define keystroke:
;(define-key-combo :raise-pointered-window
--- /project/eclipse/cvsroot/eclipse/input.lisp 2009/02/20 18:03:55 1.53
+++ /project/eclipse/cvsroot/eclipse/input.lisp 2009/11/17 21:17:29 1.54
@@ -1,5 +1,5 @@
;;; -*- 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
@@ -148,13 +148,12 @@
(undecore-application widget :state 0)
(setf (wm-state window) 3)))))
(decoration
- (let ((application (get-child widget :application)))
+ (let ((application (get-child widget :application)))
(if (application-iconic-p application)
(setf (wm-state (widget-window application)) 3)
- (with-slots (window send-event-p) event
+ (progn
(setf send-event-p t)
(setf window (widget-window application))
- (format t "about to withdraw: ~a ~%" (wm-name window))
(event-process event root)))))))))
(defmethod event-process ((event destroy-notify) (root root))
@@ -451,13 +450,13 @@
(defmethod event-process ((event exposure) (button button))
(when (zerop (event-count event))
(let* ((master (slot-value button 'master))
- (name (if master
- (slot-value (decoration-frame-style master) 'name)
- (theme-name (root-decoration-theme *root*)))))
- (repaint button name (and master (focused-p master))))))
+ (theme (if master
+ (slot-value (decoration-frame-style master) 'theme)
+ (root-decoration-theme *root*))))
+ (repaint button theme (and master (focused-p master))))))
(defmethod event-process ((event exposure) (box box-button))
- (repaint box (theme-name (root-decoration-theme *root*)) nil))
+ (repaint box (root-decoration-theme *root*) nil))
(defmethod event-process ((event button-release) (close close-button))
(close-widget (get-child (button-master close) :application)))
--- /project/eclipse/cvsroot/eclipse/package.lisp 2005/01/16 23:25:59 1.19
+++ /project/eclipse/cvsroot/eclipse/package.lisp 2009/11/17 21:17:29 1.20
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: User -*-
-;;; $Id: package.lisp,v 1.19 2005/01/16 23:25:59 ihatchondo Exp $
+;;; $Id: package.lisp,v 1.20 2009/11/17 21:17:29 ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2002 Iban HATCHONDO
@@ -181,7 +181,7 @@
#:pixmap-width ;function
#:procede-decoration ;function
#:query-application-tree ;function
- #:%quit% ;function
+ #:quit ;function
#:realize-menu-items ;function
#:realize-pop-up ;function
#:recompute-wm-normal-hints ;function
@@ -254,6 +254,7 @@
#:frame-item-pixmaps ;generic function
#:frame-item-sizes ;generic function
#:frame-item-width ;generic function
+ #:frame-style-theme ;generic function
#:free-frame-style ;generic function
#:get-child ;generic function
#:get-pixmap ;generic function
--- /project/eclipse/cvsroot/eclipse/themer.lisp 2009/11/17 18:08:43 1.12
+++ /project/eclipse/cvsroot/eclipse/themer.lisp 2009/11/17 21:17:29 1.13
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: themer.lisp,v 1.12 2009/11/17 18:08:43 ihatchondo Exp $
+;;; $Id: themer.lisp,v 1.13 2009/11/17 21:17:29 ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2002 Iban HATCHONDO
@@ -31,11 +31,11 @@
(gethash name *themes*))
(defclass frame-style ()
- ((name
- :initform "no name"
- :type string
- :initarg :theme-name
- :reader frame-style-theme-name)
+ ((theme
+ :initform nil
+ :type (or null theme)
+ :initarg style-theme
+ :reader frame-style-theme)
(title-bar-position
:initform :top
:type keyword
@@ -239,6 +239,9 @@
(defmethod initialize-instance :after ((theme theme) &rest options)
(declare (ignorable options))
+ (with-slots (default-style transient-style) theme
+ (when default-style (setf (slot-value default-style 'theme) theme))
+ (when transient-style (setf (slot-value transient-style 'theme) theme)))
(setf (gethash (theme-name theme) *themes*) theme))
;;;; build-in no decoration theme.
@@ -247,7 +250,6 @@
(make-instance 'theme :name "no-decoration"
:default-style (make-instance 'default-style
- :theme-name "no-decoration"
:title-bar-position :none))
;;;; misc functions.
@@ -299,11 +301,8 @@
;;;; theme manipulation.
-;; I defined this here, just to avoid compilation warnings.
-;; But it doesn't matter, because just before loading a theme
-;; (fmakunbound 'initialize-frame) is called.
-(defun initialize-frame (directory-name window)
- (declare (ignorable directory-name window))
+(defmethod initialize-frame (theme-class-symbol directory-name window)
+ (declare (ignorable theme-class-symbol directory-name window))
(values))
(defun free-theme (name)
@@ -316,11 +315,13 @@
(defun load-theme (root-window name)
"Loads and returns theme named by parameter name. Themes are cached."
- (unless (lookup-theme name)
- (fmakunbound 'initialize-frame)
- (setf name (ensure-theme-directory-exists name))
- (load (concatenate 'string name "theme.o"))
- (setf name (theme-name (initialize-frame name root-window))))
+ (unless (lookup-theme name)
+ (let* ((tclass (string-upcase name))
+ (theme-package (concatenate 'string tclass "-ECLIPSE-THEME")))
+ (setf name (ensure-theme-directory-exists name))
+ (load (concatenate 'string name "theme.o"))
+ (let ((tclass (with-standard-io-syntax (intern tclass theme-package))))
+ (setf name (theme-name (initialize-frame tclass name root-window))))))
(use-package (format nil "~:@(~A~)-ECLIPSE-THEME" name))
(lookup-theme name))
@@ -407,28 +408,30 @@
((style1 title-pos1 bkgrd1 parts-to-redraw-on-focus1 items1)
(style2 title-pos2 bkgrd2 parts-to-redraw-on-focus2 items2))
(mapcar #'parse-args forms)
-
- `(defun initialize-frame (dir window)
- (let ((fs1 ,(and items1
+ (let ((theme-class (format nil "~:@(~a~)" (symbol-value theme-name))))
+ `(progn
+ (defclass ,(intern theme-class) (eclipse::theme) ()
+ (:documentation ,(format nil "~a theme base class" theme-name)))
+ (defmethod eclipse-internals::initialize-frame
+ ((name (eql ',(intern theme-class))) dir window)
+ (let ((fs1 ,(and items1
`(make-instance
',(intern (symbol-name style1) "ECLIPSE-INTERNALS")
- :theme-name ,theme-name
:title-bar-position ,title-pos1
:background (make-background ,bkgrd1 window dir)
:parts-to-redraw-on-focus
',parts-to-redraw-on-focus1)))
- (fs2 ,(and items2
+ (fs2 ,(and items2
`(make-instance
',(intern (symbol-name style2) "ECLIPSE-INTERNALS")
- :theme-name ,theme-name
:title-bar-position ,title-pos2
:background (make-background ,bkgrd2 window dir)
:parts-to-redraw-on-focus
',parts-to-redraw-on-focus2))))
- ,(unless items2 `(declare (ignorable fs2)))
- ,(when items1 (define-style `fs1 items1 `dir `window))
- ,(when items2 (define-style `fs2 items2 `dir `window `fs1))
- (make-instance 'eclipse::theme :name ,theme-name
- ,@(and style1 `(,style1 fs1))
- ,@(and style2 `(,style2 fs2))))))))
+ ,(unless items2 `(declare (ignorable fs2)))
+ ,(when items1 (define-style `fs1 items1 `dir `window))
+ ,(when items2 (define-style `fs2 items2 `dir `window `fs1))
+ (make-instance ',(intern theme-class) :name ,theme-name
+ ,@(and style1 `(,style1 fs1))
+ ,@(and style2 `(,style2 fs2))))))))))
--- /project/eclipse/cvsroot/eclipse/widgets.lisp 2009/11/17 17:33:21 1.58
+++ /project/eclipse/cvsroot/eclipse/widgets.lisp 2009/11/17 21:17:29 1.59
@@ -1,5 +1,5 @@
;;; -*- 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
@@ -73,12 +73,12 @@
maximization the widget will be enlarged to cover the whole screen except
any existing panels (e.g applications with the :_net_wm_window_type_dock
atom present in there _net_wm_window_type property.
- widget (base-widget): the widget to (un)maximize.
- code (integer 1 3):
- 1 operates on width and height.
- 2 operates on height.
- 3 operates on width.
- :fill-p (boolean): If NIL, cover the whole screen (except dock type
+ - widget (base-widget): the widget to (un)maximize.
+ - code (integer 1 3):
+ -- 1 operates on width and height.
+ -- 2 operates on height.
+ -- 3 operates on width.
+ - :fill-p (boolean): If NIL, cover the whole screen (except dock type
applications). If T, finds the first region of the screen that does
not overlap applications not already overlapped by the widget."))
@@ -96,14 +96,14 @@
(:documentation "Returns T if one of the state :win_state_fixed_position
:_net_wm_state_sticky is set for the widget."))
-(defgeneric repaint (widget theme-name focus)
- (:method (widget theme-name focus) nil)
+(defgeneric repaint (widget theme focus)
+ (:method (widget theme focus) nil)
(: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.
+
+ It is specialized on widget type, frame-style theme 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
@@ -567,16 +567,16 @@
(defconstant +std-button-mask+
'(:button-press :button-release :button-motion :owner-grab-button :exposure))
-(defmethod repaint ((widget button) theme-name (focus t))
- (declare (ignorable theme-name focus))
+(defmethod repaint ((widget button) theme (focus t))
+ (declare (ignorable theme focus))
(with-slots (item-to-draw window gcontext) widget
(xlib:clear-area window)
(typecase item-to-draw
(string (draw-centered-text window gcontext item-to-draw))
(xlib:pixmap (draw-pixmap window gcontext item-to-draw)))))
-(defmethod repaint ((widget button) theme-name (focus null))
- (declare (ignorable theme-name focus))
+(defmethod repaint ((widget button) theme (focus null))
+ (declare (ignorable theme focus))
(xlib:clear-area (widget-window widget)))
(defmethod shaded-p ((widget button))
@@ -654,8 +654,8 @@
(window-position window) (values x y)
(slot-value box 'item-to-draw) m))))))
-(defmethod repaint ((widget box-button) theme-name focus &aux x)
- (declare (ignorable theme-name focus))
+(defmethod repaint ((widget box-button) theme focus &aux x)
+ (declare (ignorable theme focus))
(with-slots (window item-to-draw gcontext pixmap) widget
(xlib:clear-area window)
(when pixmap
@@ -713,19 +713,19 @@
(declare (ignorable value))
(with-slots (window master) button
(when (decoration-p master)
- (with-slots (name) (decoration-frame-style master)
- (repaint button name (focused-p master))))))
+ (with-slots (theme) (decoration-frame-style master)
+ (repaint button theme (focused-p master))))))
-(defmethod repaint ((widget push-button) theme-name (focus t))
- (declare (ignorable theme-name focus))
+(defmethod repaint ((widget push-button) theme (focus t))
+ (declare (ignorable theme focus))
(with-slots (window gcontext armed active-p item-to-draw) widget
(xlib:clear-area window)
(let ((p (and armed active-p (push-button-pixmap widget :focused-click))))
(when (or p item-to-draw)
(draw-pixmap window gcontext (or p item-to-draw))))))
-(defmethod repaint ((widget push-button) theme-name (focus null))
- (declare (ignorable theme-name focus))
+(defmethod repaint ((widget push-button) theme (focus null))
+ (declare (ignorable theme focus))
(with-slots (window gcontext armed active-p) widget
(xlib:clear-area window)
(let ((pixmap (push-button-pixmap widget :unfocused-click)))
@@ -752,8 +752,8 @@
(hmargin :initform 0)
(parent :initform nil)))
-(defmethod repaint ((widget title-bar) theme-name focus)
- (declare (ignorable theme-name focus))
+(defmethod repaint ((widget title-bar) theme focus)
+ (declare (ignorable theme focus))
(with-slots (item-to-draw window gcontext) widget
(xlib:clear-area window)
(when item-to-draw
@@ -931,8 +931,8 @@
(and pixmap-to-free (xlib:free-pixmap pixmap-to-free))
(setf pixmap-to-free nil)))
-(defmethod repaint ((widget icon) theme-name focus)
- (declare (ignorable theme-name focus))
+(defmethod repaint ((widget icon) theme focus)
+ (declare (ignorable theme focus))
(with-slots (window item-to-draw gcontext) widget
(xlib:clear-area window)
(draw-centered-text window gcontext item-to-draw :color *white*)))
--- /project/eclipse/cvsroot/eclipse/wm.lisp 2009/11/17 17:31:25 1.58
+++ /project/eclipse/cvsroot/eclipse/wm.lisp 2009/11/17 21:17:29 1.59
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: wm.lisp,v 1.58 2009/11/17 17:31:25 ihatchondo Exp $
+;;; $Id: wm.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
@@ -159,9 +159,9 @@
(defmethod dispatch-repaint ((master decoration)
&key (focus (focused-p master)))
(declare (optimize (speed 3) (safety 1)))
- (with-slots (parts-to-redraw-on-focus name) (decoration-frame-style master)
- (declare (type string name))
- (mapc #'(lambda (k) (repaint (get-child master k) name focus))
+ (with-slots (parts-to-redraw-on-focus theme) (decoration-frame-style master)
+ (declare (type theme theme))
+ (mapc #'(lambda (k) (repaint (get-child master k) theme focus))
parts-to-redraw-on-focus)))
(defun recompute-wm-normal-hints (window hmargin vmargin)
@@ -720,7 +720,7 @@
((window-not-decorable-p window (application-type application))
(setf (netwm:net-frame-extents window) (values 0 0 0 0))
(setf (wm-state window) 1)
- (xlib:map-window window))
+ (xlib:map-window window))
(t (decore-application window application :map t)))
(with-slots (wants-focus-p input-model type) application
(unless (member :_net_wm_window_type_desktop type)
@@ -737,7 +737,7 @@
:type boolean :reader close-application-p)))
(defun eclipse-internal-loop ()
- (let* ((exit 0) time)
+ (let* ((exit 0))
;; Sets the root window pop-up menu
(when *menu-1-exit-p*
@@ -765,10 +765,9 @@
(xlib:with-server-grabbed (*display*)
(mapc (lambda (w)
- (unless (ignore-errors (ignorable-window-p w))
+ (unless (ignore-errors (ignorable-window-p w))
(procede-decoration w)))
(xlib:query-tree *root-window*))))
-
;; Main loop
(loop
(catch 'general-error
@@ -786,7 +785,7 @@
when (application-p val)
if *close-display-p* do (close-widget val)
else do (undecore-application val))
- (setf time 10 exit 2))
+ (setf exit 2))
(2 (when (root-sm-conn *root*)
(close-sm-connection *root* :exit-p nil))
(xlib:display-finish-output *display*)
