+(defun dialog-response-id (dialog response &optional create-p error-p)
+ "Returns a numeric response id"
+ (if (typep response 'response-type)
+ (response-type-to-int response)
+ (let ((responses (object-data dialog 'responses)))
+ (cond
+ ((and responses (position response responses :test #'equal)))
+ (create-p
+ (cond
+ (responses
+ (vector-push-extend response responses)
+ (1- (length responses)))
+ (t
+ (setf
+ (object-data dialog 'responses)
+ (make-array 1 :adjustable t :fill-pointer t
+ :initial-element response))
+ 0)))
+ (error-p
+ (error "Invalid response: ~A" response))))))
+
+(defun dialog-find-response (dialog id)
+ "Finds a symbolic response given a numeric id"
+ (if (< id 0)
+ (int-to-response-type id)
+ (aref (object-data dialog 'responses) id)))
+
+
+(defmethod compute-signal-id ((dialog dialog) signal)
+ (if (dialog-response-id dialog signal)
+ (ensure-signal-id 'response dialog)
+ (call-next-method)))
+
+(defmethod compute-signal-function ((dialog dialog) signal function object)
+ (declare (ignore function object))
+ (let ((callback (call-next-method))
+ (id (dialog-response-id dialog signal)))
+ (if id
+ #'(lambda (dialog response)
+ (when (= response id)
+ (funcall callback dialog)))
+ callback)))
+
+(defbinding dialog-run () nil
+ (dialog dialog))
+
+(defbinding dialog-response (dialog response) nil
+ (dialog dialog)
+ ((dialog-response-id dialog response nil t) int))
+
+
+(defbinding %dialog-add-button () button
+ (dialog dialog)
+ (text string)
+ (response-id int))
+
+(defun dialog-add-button (dialog label &optional (response label)
+ &key default object after)
+ "Adds a button to the dialog."
+ (let* ((signal (if (functionp response)
+ label
+ response))
+ (id (dialog-response-id dialog signal t))
+ (button (%dialog-add-button dialog label id)))
+ (when (functionp response)
+ (signal-connect dialog signal response :object object :after after))
+ (when default
+ (%dialog-set-default-response dialog id))
+ button))
+
+
+(defbinding %dialog-add-action-widget () nil
+ (dialog dialog)
+ (action-widget widget)
+ (response-id int))
+
+(defun dialog-add-action-widget (dialog widget &optional (response widget)
+ &key default object after)
+ (let* ((signal (if (functionp response)
+ widget
+ response))
+ (id (dialog-response-id dialog signal t)))
+ (unless (widget-hidden-p widget)
+ (widget-show widget))
+ (%dialog-add-action-widget dialog widget id)
+ (when (functionp response)
+ (signal-connect dialog signal response :object object :after after))
+ (when default
+ (%dialog-set-default-response dialog id))
+ widget))
+
+
+(defbinding %dialog-set-default-response () nil
+ (dialog dialog)
+ (response-id int))
+
+(defun dialog-set-default-response (dialog response)
+ (%dialog-set-default-response
+ dialog (dialog-response-id dialog response nil t)))
+
+(defbinding dialog-set-response-sensitive (dialog response sensitive) nil
+ (dialog dialog)
+ ((dialog-response-id dialog response nil t) int)
+ (sensitive boolean))
+
+#+gtk2.6
+(defbinding alternative-dialog-button-order-p (&optional screen) boolean
+ (screen (or null gdk:screen)))
+
+#+gtk2.6
+(defbinding (dialog-set-alternative-button-order
+ "gtk_dialog_set_alternative_button_order_from_array")
+ (dialog new-order) nil
+ (dialog dialog)
+ ((length new-order) int)
+ ((map 'vector #'(lambda (response)
+ (dialog-response-id dialog response nil t))
+ new-order) (vector int)))
+
+
+#+gtk2.8
+(progn
+ (defbinding %dialog-get-response-for-widget () int
+ (dialog dialog)
+ (widget widget))
+
+ (defun dialog-get-response-for-widget (dialog widget)
+ (dialog-find-response dialog (dialog-get-response-for-widget dialog widget))))
+
+
+(defmethod container-add ((dialog dialog) (child widget) &rest args)
+ (apply #'container-add (dialog-vbox dialog) child args))
+
+
+(defmethod container-remove ((dialog dialog) (child widget))
+ (container-remove (dialog-vbox dialog) child))
+
+(defmethod container-children ((dialog dialog))
+ (container-children (dialog-vbox dialog)))
+
+(defmethod (setf container-children) (children (dialog dialog))
+ (setf (container-children (dialog-vbox dialog)) children))