[cells-cvs] CVS Celtk

[fgoenninger]

Update of /project/cells/cvsroot/Celtk
In directory clnet:/tmp/cvs-serv17218

Modified Files:
	composites.lisp 
Log Message:
Changed: Decoration handling now done via mixin class. No available
for Toplevel and Window classes.

--- /project/cells/cvsroot/Celtk/composites.lisp	2006/09/28 20:54:55	1.16
+++ /project/cells/cvsroot/Celtk/composites.lisp	2006/09/29 09:15:24	1.17
@@ -18,11 +18,12 @@
 
 (in-package :Celtk)
 
-
+(defmd decoration-mixin ()
+  (decoration (c-in :normal)))
 
 ;;; --- toplevel ---------------------------------------------
 
-(deftk toplevel (widget)
+(deftk toplevel (widget decoration-mixin)
   ()
   (:tk-spec toplevel
     -borderwidth -cursor -highlightbackground -highlightcolor
@@ -35,7 +36,7 @@
 
 ;; --- panedwindow -----------------------------------------
 
-(deftk panedwindow (widget)
+(deftk panedwindow (widget decoration-mixin)
   ()
   (:tk-spec panedwindow
     -background -borderwidth -cursor -height
@@ -88,7 +89,7 @@
 
 (export! keyboard-modifiers)
 
-(defmd window (composite-widget)
+(defmd window (composite-widget decoration-mixin)
   (title$ (c? (string-capitalize (class-name (class-of self)))))
   (dictionary (make-hash-table :test 'equalp))
   (tkwins (make-hash-table))
@@ -102,8 +103,7 @@
   (tkfont-info (tkfont-info-loader))
   initial-focus
   on-key-down
-  on-key-up
-  (decoration (c-in :normal)))
+  on-key-up)
 
 (defmethod do-on-key-down :before (self &rest args &aux (keysym (car args)))
   (trc nil "ctk::do-on-key-down window" keysym (keyboard-modifiers .tkw))
@@ -118,16 +118,41 @@
       (setf (keyboard-modifiers .tkw)
         (delete mod (keyboard-modifiers .tkw))))))
 
-(defobserver decoration ((self window)) ;; == wm overrideredirect 0|1
+;;; Helper function that actually executes decoration change
+(defun %%do-decoration (widget decoration)
+  (let ((path (path widget)))
+    (ecase decoration
+      (:none    (progn
+		  (tk-format '(:pre-make-tk decoration)
+			     "wm withdraw ~a" path)    
+		  (tk-format '(:pre-make-tk decoration)
+			     "wm overrideredirect ~a 1" path)
+		  (tk-format '(:pre-make-tk decoration)
+			     "wm deiconify ~a" path)
+		  (tk-format '(:pre-make-tk decoration)
+			     "update idletasks" path)
+		  ))
+      (:normal  (progn
+		  (tk-format '(:pre-make-tk decoration)
+			     "wm withdraw ~a" path)    
+		  (tk-format '(:pre-make-tk decoration)
+			     "wm overrideredirect ~a 0" path)
+		  (tk-format '(:pre-make-tk decoration)
+			     "wm deiconify ~a" path)
+		  (tk-format '(:pre-make-tk decoration)
+			     "update idletasks" path))))))
+
+;;; Decoration observer for all widgets that inherit from decoration-mixin
+;;; On Mac OS X this is a one-way operation. When created without decorations
+;;; then it is not possible to restore the decorations and vice versa. So on
+;;; OS X the window decoration will stay as you created the window with.
+
+(defobserver decoration ((self decoration-mixin)) ;; == wm overrideredirect 0|1
   (assert (or (eq new-value nil)        ;; Does not change decoration
 	      (eq new-value :normal)    ;; "normal"
               (eq new-value :none)))    ;; No title bar, no nothing ...
   (if (not (eq new-value old-value))
-      (case new-value
-	(:none    (tk-format '(:pre-make-tk new-value)
-			     "wm overrideredirect ~a 1" (^path)))
-	(:normal  (tk-format '(:pre-make-tk new-value)
-			     "wm overrideredirect ~a 0" (^path))))))
+      (%%do-decoration self new-value)))
 
 (defobserver initial-focus ()
   (when new-value