+ (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 names button buttons))
+ (prog1
+ (call-next-method)
+ (initial-apply-add dialog #'dialog-add-button initargs :button :buttons)))
+
+
+(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 (user-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
+ (user-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 (user-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 args)
+ (declare (ignore function object args))
+ (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))
+
+#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
+(defbinding alternative-dialog-button-order-p (&optional screen) boolean
+ (screen (or null gdk:screen)))
+
+#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
+(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)))
+
+
+#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
+(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))
+
+
+;;; Drawing Area
+
+(defun drawing-area-scroll (drawing-area dx dy)
+ (gdk:window-scroll (widget-window drawing-area) dx dy))
+
+
+;;; 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
+
+(define-callback-marshal %entry-completion-match-callback boolean
+ (entry-completion string tree-iter))
+
+(defbinding entry-completion-set-match-func (completion function) nil
+ (completion entry-completion)
+ (%entry-completion-match-callback callback)
+ ((register-callback-function function) unsigned-int)
+ (user-data-destroy-callback callback))
+
+(defbinding entry-completion-complete () nil
+ (completion entry-completion))
+
+#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
+(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
+ #?-(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
+ (warn "Initarg :PIXBUF-FORMATS not supportet in this version of Gtk")
+ #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
+ (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))
+
+#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
+(defbinding file-filter-add-pixbuf-formats () nil
+ (filter file-filter))
+
+(define-callback-marshal %file-filter-callback boolean (file-filter-info))
+
+(defbinding file-filter-add-custom (filter needed function) nil
+ (filter file-filter)
+ (needed file-filter-flags)
+ (%file-filter-callback callback)
+ ((register-callback-function function) unsigned-int)
+ (user-data-destroy-callback callback))
+
+(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))))
+
+#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
+(defbinding image-clear () nil
+ (image image))
+
+
+
+;;; 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
+
+(defmethod shared-initialize ((label label) names &key pattern)
+ (declare (ignore names))
+ (call-next-method)
+ (when pattern
+ (setf (label-pattern label) pattern)))
+
+(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))