+ (unless model
+ (setf (combo-box-entry-text-column combo-box-entry) 0)))
+
+
+;;;; Dialog
+
+(defmethod shared-initialize ((dialog dialog) names &rest initargs
+ &key button buttons)
+ (declare (ignore button buttons))
+ (prog1
+ (call-next-method)
+ (initial-apply-add dialog #'dialog-add-button initargs :button :buttons)))
+
+
+(defun %dialog-find-response-id-num (dialog id &optional create-p error-p)
+ (or
+ (cadr (assoc id (rest (type-expand-1 'response-type))))
+ (let ((response-ids (object-data dialog 'response-id-key)))
+ (cond
+ ((and response-ids (position id response-ids :test #'equal)))
+ (create-p
+ (cond
+ (response-ids
+ (vector-push-extend id response-ids)
+ (1- (length response-ids)))
+ (t
+ (setf
+ (object-data dialog 'response-id-key)
+ (make-array 1 :adjustable t :fill-pointer t :initial-element id))
+ 0)))
+ (error-p
+ (error "Invalid response: ~A" id))))))
+
+(defun %dialog-find-response-id (dialog response-id-num)
+ (if (< response-id-num 0)
+ (car
+ (rassoc
+ (list response-id-num)
+ (rest (type-expand-1 'response-type)) :test #'equal))
+ (aref (object-data dialog 'response-id-key) response-id-num )))
+
+
+(defmethod signal-connect ((dialog dialog) signal function &key object after)
+ (let ((response-id-num (%dialog-find-response-id-num dialog signal)))
+ (cond
+ (response-id-num
+ (call-next-method
+ dialog 'response
+ #'(lambda (dialog id)
+ (when (= id response-id-num)
+ (cond
+ ((eq object t) (funcall function dialog))
+ (object (funcall function object))
+ (t (funcall function)))))
+ :object t :after after))
+ ((call-next-method)))))
+
+
+(defbinding dialog-run () nil
+ (dialog dialog))
+
+(defbinding dialog-response (dialog response-id) nil
+ (dialog dialog)
+ ((%dialog-find-response-id-num dialog response-id nil t) int))
+
+
+(defbinding %dialog-add-button () button
+ (dialog dialog)
+ (text string)
+ (response-id-num int))
+
+(defun dialog-add-button (dialog label &optional (response label)
+ &key default object after)
+ "Adds a button to the dialog."
+ (let* ((id (if (functionp response)
+ label
+ response))
+ (id-num (%dialog-find-response-id-num dialog id t))
+ (button (%dialog-add-button dialog label id-num)))
+ (when (functionp response)
+ (signal-connect dialog id response :object object :after after))
+ (when default
+ (%dialog-set-default-response dialog id-num))
+ button))
+
+
+(defbinding %dialog-add-action-widget () button
+ (dialog dialog)
+ (action-widget widget)
+ (response-id-num int))
+
+(defun dialog-add-action-widget (dialog widget &optional (response widget)
+ &key default object after)
+ (let* ((id (if (functionp response)
+ widget
+ response))
+ (id-num (%dialog-find-response-id-num dialog id t)))
+ (%dialog-add-action-widget dialog widget id-num)
+ (when (functionp response)
+ (signal-connect dialog id response :object object :after after))
+ (when default
+ (%dialog-set-default-response dialog id-num))
+ widget))
+
+
+(defbinding %dialog-set-default-response () nil
+ (dialog dialog)
+ (response-id-num int))
+
+(defun dialog-set-default-response (dialog response-id)
+ (%dialog-set-default-response
+ dialog (%dialog-find-response-id-num dialog response-id nil t)))
+
+(defbinding dialog-set-response-sensitive (dialog response-id sensitive) nil
+ (dialog dialog)
+ ((%dialog-find-response-id-num dialog response-id 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)
+ (dialog dialog)
+ ((length new-order) int)
+ ((map 'vector #'(lambda (id)
+ (%dialog-find-response-id-num dialog id nil t))
+ new-order) (vector int)))
+
+
+(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))
+
+
+;;; Entry
+
+(defbinding entry-get-layout-offsets () nil
+ (entry entry)
+ (x int :out)
+ (y int :out))
+
+(defbinding entry-layout-index-to-text-index () int
+ (entry entry)
+ (layout-index int))
+
+(defbinding entry-text-index-to-layout-index () int
+ (entry entry)
+ (text-index int))
+
+
+;;; Entry Completion
+
+(def-callback-marshal %entry-completion-match-func
+ (boolean entry-completion string (copy-of tree-iter)))
+
+(defbinding entry-completion-set-match-func (completion function) nil
+ (completion entry-completion)
+ ((callback %entry-completion-match-func) pointer)
+ ((register-callback-function function) unsigned-int)
+ ((callback user-data-destroy-func) pointer))
+
+(defbinding entry-completion-complete () nil
+ (completion entry-completion))
+
+#+gtk2.6
+(defbinding entry-completion-insert-prefix () nil
+ (completion entry-completion))
+
+(defbinding entry-completion-insert-action-text () nil
+ (completion entry-completion)
+ (index int)
+ (text string))
+
+(defbinding entry-completion-insert-action-markup () nil
+ (completion entry-completion)
+ (index int)
+ (markup string))
+
+(defbinding entry-completion-delete-action () nil
+ (completion entry-completion)
+ (index int))
+
+
+;;; File Chooser
+
+(defmethod initialize-instance ((file-chooser file-chooser) &rest initargs
+ &key filter filters shortcut-folder
+ shortcut-folders shortcut-folder-uti
+ shortcut-folder-uris)
+ (declare (ignore filter filters shortcut-folder shortcut-folders
+ shortcut-folder-uti shortcut-folder-uris))
+ (prog1
+ (call-next-method)
+ (initial-add file-chooser #'file-chooser-add-filter
+ initargs :filer :filters)
+ (initial-add file-chooser #'file-chooser-add-shortcut-folder
+ initargs :shortcut-folder :shortcut-folders)
+ (initial-add file-chooser #'file-chooser-add-shortcut-folder-uri
+ initargs :shortcut-folder-uri :shortcut-folders-uris)))
+
+
+(defbinding file-chooser-select-filename () boolean
+ (file-chooser file-chooser)
+ (filename string))
+
+(defbinding file-chooser-unselect-filename () nil
+ (file-chooser file-chooser)
+ (filename string))
+
+(defbinding file-chooser-select-all () boolean
+ (file-chooser file-chooser))
+
+(defbinding file-chooser-unselect-all () boolean
+ (file-chooser file-chooser))
+
+(defbinding file-chooser-get-filenames () (gslist string)
+ (file-chooser file-chooser))
+
+(defbinding file-chooser-select-uri () boolean
+ (file-chooser file-chooser)
+ (uri string))
+
+(defbinding file-chooser-unselect-uri () nil
+ (file-chooser file-chooser)
+ (uri string))
+
+(defbinding file-chooser-get-uris () (gslist string)
+ (file-chooser file-chooser))
+
+(defbinding file-chooser-add-filter () nil
+ (file-chooser file-chooser)
+ (filter file-filter))
+
+(defbinding file-chooser-remove-filter () nil
+ (file-chooser file-chooser)
+ (filter file-filter))
+
+(defbinding file-chooser-list-filters () (gslist file-filter)
+ (file-chooser file-chooser))
+
+(defbinding file-chooser-add-shortcut-folder () boolean
+ (file-chooser file-chooser)
+ (folder string)
+ (nil null))
+
+(defbinding file-chooser-remove-shortcut-folder () nil
+ (file-chooser file-chooser)
+ (folder string)
+ (nil null))
+
+(defbinding file-chooser-list-shortcut-folders () (gslist string)
+ (file-chooser file-chooser))
+
+(defbinding file-chooser-add-shortcut-folder-uri () boolean
+ (file-chooser file-chooser)
+ (uri string)
+ (nil null))
+
+(defbinding file-chooser-remove-shortcut-folder-uri () nil
+ (file-chooser file-chooser)
+ (uri string)
+ (nil null))
+
+(defbinding file-chooser-list-shortcut-folder-uris () (gslist string)
+ (file-chooser file-chooser))
+
+
+;;; File Filter
+
+(defmethod initialize-instance ((file-filter file-filter) &rest initargs
+ &key mime-type mime-types pattern patterns
+ pixbuf-formats)
+ (declare (ignore mime-type mime-types pattern patterns))
+ (prog1
+ (call-next-method)
+ (when pixbuf-formats
+ #-gtk2.6(warn "Initarg :PIXBUF-FORMATS not supportet in this version of Gtk")
+ #+gtk2.6(file-filter-add-pixbuf-formats file-filter))
+ (initial-add file-filter #'file-filter-add-mime-type
+ initargs :mime-type :mime-types)
+ (initial-add file-filter #'file-filter-add-pattern
+ initargs :pattern :patterns)))
+
+
+(defbinding file-filter-add-mime-type () nil
+ (filter file-filter)
+ (mime-type string))
+
+(defbinding file-filter-add-pattern () nil
+ (filter file-filter)
+ (pattern string))
+
+#+gtk2.6
+(defbinding file-filter-add-pixbuf-formats () nil
+ (filter file-filter))
+
+(def-callback-marshal %file-filter-func (boolean file-filter-info))
+
+(defbinding file-filter-add-custom (filter needed function) nil
+ (filter file-filter)
+ (needed file-filter-flags)
+ ((callback %file-filter-func) pointer)
+ ((register-callback-function function) unsigned-int)
+ ((callback user-data-destroy-func) pointer))
+
+(defbinding file-filter-get-needed () file-filter-flags
+ (filter file-filter))
+
+(defbinding file-filter-filter () boolean
+ (filter file-filter)
+ (filter-info file-filter-info))
+
+
+
+;;; Image
+
+(defbinding image-set-from-file () nil
+ (image image)
+ (filename pathname))
+
+(defmethod (setf image-pixmap) ((data vector) (image image))
+ (multiple-value-bind (pixmap mask) (gdk:pixmap-create data)
+ (setf (image-pixmap image) pixmap)
+ (setf (image-mask image) mask)))
+
+(defmethod initialize-instance ((image image) &rest initargs &key pixmap file)
+ (cond
+ ((typep pixmap 'vector)
+ (multiple-value-bind (pixmap mask) (gdk:pixmap-create pixmap)
+ (apply #'call-next-method image :pixmap pixmap :mask mask initargs)))
+ (file
+ (prog1
+ (call-next-method)
+ (image-set-from-file image file)))
+ ((call-next-method))))
+
+(defun create-image-widget (source &optional mask)
+ (etypecase source
+ (gdk:pixbuf (make-instance 'image :pixbuf source))
+ (string (make-instance 'image :stock source))
+ (pathname (make-instance 'image :file source))
+ ((or list vector) (make-instance 'image :pixmap source))
+ (gdk:pixmap (make-instance 'image :pixmap source :mask mask))))
+
+
+;;; Image menu item
+
+(defmethod initialize-instance ((item image-menu-item) &rest initargs &key image)
+ (if (and image (not (typep image 'widget)))
+ (apply #'call-next-method item :image (create-image-widget image) initargs)
+ (call-next-method)))
+
+
+(defmethod (setf image-menu-item-image) ((widget widget) (item image-menu-item))
+ (setf (slot-value item 'image) widget))
+
+(defmethod (setf image-menu-item-image) (image (item image-menu-item))
+ (setf (image-menu-item-image item) (create-image-widget image)))
+
+
+;;; Label
+
+(defbinding label-get-layout-offsets () nil
+ (label label)
+ (x int :out)
+ (y int :out))
+
+(defbinding label-select-region () nil
+ (label label)
+ (start int)
+ (end int))
+
+(defbinding label-get-selection-bounds () boolean
+ (label label)
+ (start int :out)
+ (end int :out))