[cells-gtk-cvs] CVS update: root/cells-gtk/dialogs.lisp - cells-gtk-cvs@common-lisp.net - mailman3.common-lisp.net

26 Feb 2005

Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory common-lisp.net:/tmp/cvs-serv7473/cells-gtk
Modified Files:
    dialogs.lisp 
Log Message:
New stuff to implement add a child widget to dialogs (for prompting for strings, for example). This reminds me that I don't have this in the test-gtk demo yet.
Date: Sat Feb 26 23:24:27 2005
Author: pdenno
Index: root/cells-gtk/dialogs.lisp
diff -u root/cells-gtk/dialogs.lisp:1.4 root/cells-gtk/dialogs.lisp:1.5

--- root/cells-gtk/dialogs.lisp:1.4	Thu Feb 17 21:00:13 2005
+++ root/cells-gtk/dialogs.lisp	Sat Feb 26 23:24:27 2005
@@ -18,12 +18,14 @@
(in-package :cgtk)
+
 (def-widget message-dialog (window)
   ((message :accessor message :initarg :message :initform nil)
    (message-type :accessor message-type :initarg :message-type :initform :info)
    (buttons-type :accessor buttons-type :initarg :buttons-type :initform (c? (if (eql (message-type self) :question)
    									 :yes-no
-										 :close))))
+										 :close)))
+   (content-area :accessor content-area :initarg :content-area :initform nil))
   (markup)
   ()
   :position :mouse
@@ -40,7 +42,7 @@
    		(:close 2)
    		(:cancel 3)
    		(:yes-no 4)
-			(:ok-cancel 4))
+			(:ok-cancel 5))
    	      (message self))))
(defmethod md-awaken :after ((self message-dialog))
@@ -53,18 +55,27 @@
        (-8 :yes)
        (-9 :no))))
   (gtk-widget-destroy (id self))
-  (gtk-object-forget (id self) self))
+  (gtk-object-forget (id self) self)
+  (with-slots (content-area) self
+    (when content-area 
+      (setf (md-value self) (md-value content-area))
+      (gtk-object-forget (id content-area) content-area))))
       
 (defun show-message (text &rest inits)
   (let ((message-widget (to-be (apply #'mk-message-dialog :message text inits))))
     (md-value message-widget)))
-
(def-object file-filter ()
   ((mime-types :accessor mime-types :initarg :mime-types :initform nil)
    (patterns :accessor patterns :initarg :patterns :initform nil))
   (name)
   ())
+
+(def-c-output content-area ((self message-dialog))
+  (when new-value
+    (to-be new-value)
+    (let ((vbox (gtk-adds-dialog-vbox (id self))))
+        (gtk-box-pack-start vbox (id new-value) nil nil 5))))
(def-c-output mime-types ((self file-filter))
   (dolist (mime-type new-value)

    