This patch adds GtkDialog widget in dialogs.lisp. And does others
dialog widgets his heir.
I test this on Clisp 2.35 (Windows XP)
Index: cells-gtk/dialogs.lisp
===================================================================
RCS file: /project/cells-gtk/cvsroot/root/cells-gtk/dialogs.lisp,v
retrieving revision 1.7
diff -u -r1.7 dialogs.lisp
--- cells-gtk/dialogs.lisp 7 Jun 2006 16:35:03 -0000 1.7
+++ cells-gtk/dialogs.lisp 4 Aug 2006 12:03:29 -0000
@@ -18,8 +18,38 @@
(in-package :cgtk)
+(def-widget dialog (window)
+ ((content-area :accessor content-area :initarg :content-area :initform nil)
+ (fn-response :accessor fn-response :initarg :fn-response :initform (lambda
(self response) (declare (ignore self)) response))
+ (buttons :accessor buttons :initarg :buttons :initform nil)
+ (buttons-id :accessor buttons-id :initarg :buttons-id :initform (c-in nil)))
+ (markup)
+ ()
+ :position :mouse
+ :new-args nil)
-(def-widget message-dialog (window)
+(defmethod md-awaken :after ((self dialog))
+ (let ((response (gtk-dialog-run (id self))))
+ (funcall (fn-response self) self response))
+ (gtk-widget-destroy (id 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))))
+
+(def-c-output content-area ((self 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 buttons ((self dialog))
+ (when new-value
+ (setf (buttons-id self) (mapcar #'(lambda (b) (gtk-dialog-add-button (id
self) (car b) (car (cdr b)))) new-value))))
+
+
+(def-widget message-dialog (dialog)
((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)
@@ -29,6 +59,13 @@
(markup)
()
:position :mouse
+ :fn-response (lambda (self response) (setf (md-value self)
+ (case response
+ (-5 :ok)
+ (-6 :cancel)
+ (-7 :close)
+ (-8 :yes)
+ (-9 :no))))
:new-args (c? (list +c-null+
2
(ecase (message-type self)
@@ -45,22 +82,6 @@
(:ok-cancel 5))
(message self))))
-(defmethod md-awaken :after ((self message-dialog))
- (let ((response (gtk-dialog-run (id self))))
- (setf (md-value self)
- (case response
- (-5 :ok)
- (-6 :cancel)
- (-7 :close)
- (-8 :yes)
- (-9 :no))))
- (gtk-widget-destroy (id 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)))
@@ -71,12 +92,6 @@
(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)
(gtk-file-filter-add-mime-type (id self) mime-type)))
@@ -119,12 +134,16 @@
()
:new-args (c? (list (action-id self))))
-(def-widget file-chooser-dialog (file-chooser window)
+(def-widget file-chooser-dialog (file-chooser dialog)
()
()
()
:on-selection-changed nil
:position :mouse
+ :fn-response (lambda (self response) (when (eql response -5)
+ (if (select-multiple self)
+ (setf (md-value self) (gtk-file-chooser-get-filenames-strs (id self)))
+ (setf (md-value self) (gtk-file-chooser-get-filename (id self))))))
:new-args (c? (list (title self) +c-null+ (action-id self)
"gtk-cancel" -6 ;;response-cancel
(format nil "gtk-~a"
@@ -138,15 +157,6 @@
-5 ;;response-ok
+c-null+)))
-(defmethod md-awaken :after ((self file-chooser-dialog))
- (let ((response (gtk-dialog-run (id self))))
- (when (eql response -5)
- (if (select-multiple self)
- (setf (md-value self) (gtk-file-chooser-get-filenames-strs (id self)))
- (setf (md-value self) (gtk-file-chooser-get-filename (id self)))))
- (gtk-widget-destroy (id self))
- (gtk-object-forget (id self) self)))
-
(defun file-chooser (&rest inits)
(let ((dialog (to-be (apply #'mk-file-chooser-dialog inits))))
(md-value dialog)))
_______________________________________________
cells-gtk-devel site list
[email protected]
http://common-lisp.net/mailman/listinfo/cells-gtk-devel
