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*)
-
ihatchondo