+;;;; Initalization and display handling
+
+(defparameter *event-polling-interval* 0.01)
+
+#?(or (featurep :clisp) (featurep :cmu) (and (sbcl>= 1 0 6) (sbcl< 1 0 15 6)))
+(defun decompose-time (time)
+ (multiple-value-bind (sec subsec) (truncate *event-polling-interval*)
+ (values sec (truncate (* subsec 1e6)))))
+
+(defbinding (gtk-init "gtk_parse_args") () boolean
+ "Initializes the library without opening the display."
+ (nil null)
+ (nil null))
+
+(defun clg-init (&optional display multi-threading-p)
+ "Initializes the system and starts event handling."
+ (unless (gdk:display-get-default)
+ #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
+ (progn
+ #+sbcl(sb-int:set-floating-point-modes :traps nil)
+ #+cmu(ext:set-floating-point-modes :traps nil))
+
+ (gdk:gdk-init)
+ (unless (gtk-init)
+ (error "Initialization of GTK+ failed."))
+
+ (if (not multi-threading-p)
+ (%init-async-event-handling display)
+ #+sb-thread(%init-multi-threaded-event-handling display)
+ #-sb-thread(error "Multi threading not supported on this platform")))
+ (gdk:ensure-display display t))
+
+(defun clg-init-with-threading (&optional display)
+ (clg-init display t))
+
+
+#?(and (sbcl>= 1 0 6) (sbcl< 1 0 15 6))
+;; A very minimal implementation of CLISP's socket-status
+(defun socket-status (socket seconds microseconds)
+ (sb-alien:with-alien ((read-fds (sb-alien:struct sb-unix:fd-set)))
+ (let ((fd (sb-sys:fd-stream-fd (car socket))))
+ (sb-unix:fd-zero read-fds)
+ (sb-unix:fd-set fd read-fds)
+
+ (let ((num-fds-changed
+ (sb-unix:unix-fast-select
+ (1+ fd) (sb-alien:addr read-fds) nil nil
+ seconds microseconds)))
+ (unless (or (not num-fds-changed) (zerop num-fds-changed))
+ (if (peek-char nil (car socket) nil)
+ :input
+ :eof))))))
+
+(defun %init-async-event-handling (display)
+ (let ((style
+ #?(or (featurep :cmu) (sbcl< 1 0 6) (sbcl>= 1 0 15 6)) :fd-handler
+ #?-(or (featurep :cmu) (sbcl< 1 0 6) (sbcl>= 1 0 15 6)) nil))
+ (when (and
+ (find-package "SWANK")
+ (not (eq (symbol-value (find-symbol "*COMMUNICATION-STYLE*" "SWANK")) style)))
+ (error "When running clg in Slime, the communication style ~S must be used in combination with asynchronous event handling on this platform. See the README file and <http://common-lisp.net/project/slime/doc/html/Communication-style.html> for more information." style)))
+
+ #+(or cmu sbcl)
+ (signal-connect (gdk:display-manager) 'display-opened
+ #'(lambda (display)
+ (let ((fd (gdk:display-connection-number display)))
+ (unless (< fd 0)
+ (let ((handler (add-fd-handler
+ (gdk:display-connection-number display)
+ :input #'main-iterate-all)))
+ (signal-connect display 'closed
+ #'(lambda (is-error-p)
+ (declare (ignore is-error-p))
+ (remove-fd-handler handler))))))))
+
+ #?(or (featurep :cmu) (sbcl< 1 0 6) (sbcl>= 1 0 15 6))
+ (progn
+ (setq *periodic-polling-function* #'main-iterate-all)
+ #?(or (featurep :cmu) (sbcl< 1 0 6))
+ (multiple-value-setq (*max-event-to-sec* *max-event-to-usec*)
+ (decompose-time *event-polling-interval*))
+ #?(sbcl>= 1 0 15 6)
+ (setq *periodic-polling-period* *event-polling-interval*))
+
+ #?(or (featurep :clisp) (and (sbcl>= 1 0 6) (sbcl< 1 0 15 6)))
+ ;; When running in CLISP or certain versions of SBCL in Slime we need
+ ;; to hook into the Swank server to handle events asynchronously.
+ (cond
+ ((and (find-package "SWANK") (find-symbol "CHECK-SLIME-INTERRUPTS" "SWANK"))
+ (let ((check-slime-interrupts
+ (symbol-function (find-symbol "CHECK-SLIME-INTERRUPTS" "SWANK"))))
+ (setf
+ (symbol-function (find-symbol "CHECK-SLIME-INTERRUPTS" "SWANK"))
+ #'(lambda ()
+ (main-iterate-all)
+ (funcall check-slime-interrupts)))))
+ ((and (find-package "SWANK")
+ (find-symbol "READ-FROM-EMACS" "SWANK")
+ (find-symbol "*EMACS-CONNECTION*" "SWANK")
+ (find-symbol "CONNECTION.SOCKET-IO" "SWANK"))
+ (let ((connection (symbol-value (find-symbol "*EMACS-CONNECTION*" "SWANK"))))
+ (when connection
+ (let ((read-from-emacs (symbol-function (find-symbol "READ-FROM-EMACS" "SWANK")))
+ (stream (funcall (find-symbol "CONNECTION.SOCKET-IO" "SWANK") connection)))
+ (multiple-value-bind (sec usec)
+ (decompose-time *event-polling-interval*)
+ (setf (symbol-function (find-symbol "READ-FROM-EMACS" "SWANK"))
+ #'(lambda ()
+ (loop
+ (case (socket-status (cons stream :input) sec usec)
+ ((:input :eof) (return (funcall read-from-emacs)))
+ (otherwise (main-iterate-all)))))))))))
+ ((flet ((warn-main-loop ()
+ (warn "Asynchronous event handling not supported on this platform. An explicit main loop has to be started.")))
+ #+(and clisp readline)
+ (if (find-package "SWANK")
+ (warn-main-loop) ; assuming we're running in SLIME
+ ;; Readline will call the event hook at most ten times per second
+ (setf readline:event-hook #'main-iterate-all))
+ #-(and clisp readline)(warn-main-loop))))
+
+ (gdk:display-open display))
+
+#+sb-thread
+(progn
+ (defvar *main-thread* nil)
+
+ ;; Hopefully, when threading support is added to the Win32 port of
+ ;; SBCL in the future, this will work just out of the box.
+ #+win32
+ (let ((done (sb-thread:make-waitqueue))
+ (functions ())
+ (results ()))
+
+ ;; In Win32 all GDK calls have to be made from the main loop
+ ;; thread, so we add a timeout function which will poll for code and
+ ;; execute it.
+
+ (defun funcall-in-main (function)
+ (if (or
+ (not *main-thread*)
+ (eq sb-thread:*current-thread* *main-thread*))
+ (funcall function)
+ (gdk:with-global-lock
+ (push function functions)
+ (sb-thread:condition-wait done gdk:*global-lock*)
+ (pop results))))
+
+ ;; Will lock REPL on error, need to be fixed!
+ (defun %funcall-in-main-poll ()
+ (when functions
+ (loop
+ for n from 0
+ while functions
+ do (push (funcall (pop functions)) results)
+ finally (sb-thread:condition-notify done n)))
+ t))
+
+ (defmacro within-main-loop (&body body)
+ #-win32 `(gdk:with-global-lock ,@body)
+ #+win32 `(funcall-in-main #'(lambda () ,@body)))
+
+ (defun %init-multi-threaded-event-handling (display)
+ (when (and
+ (find-package "SWANK")
+ (not (eq (symbol-value (find-symbol "*COMMUNICATION-STYLE*" "SWANK")) :spawn)))
+ (error "When running clg in Slime, the communication style :spawn must be used in combination with multi threaded event handling. See the README file and <http://common-lisp.net/project/slime/doc/html/slime_45.html> for more information."))
+ (gdk:threads-init)
+ (let ((main-running (sb-thread:make-waitqueue)))
+ (gdk:with-global-lock
+ (setf *main-thread*
+ (sb-thread:make-thread
+ #'(lambda ()
+ (gdk:with-global-lock
+ (gdk:display-open display)
+ #+win32(gdk:timeout-add-with-lock (/ *event-poll-interval* 1000)
+ #'%funcall-in-main-poll)
+ (sb-thread:condition-notify main-running)
+ (main)))
+ :name "gtk event loop"))
+ (sb-thread:condition-wait main-running gdk:*global-lock*)))
+
+ ;; We need to hook into the Swank server to protect calls to GDK properly.
+ ;; This will *only* protect code entered directly in the REPL.
+ (when (find-package "SWANK")
+ (let ((repl-eval-hook (find-symbol "*SLIME-REPL-EVAL-HOOKS*" "SWANK")))
+ (if repl-eval-hook
+ (push #'(lambda (form)
+ (within-main-loop (eval form)))
+ (symbol-value (find-symbol "*SLIME-REPL-EVAL-HOOKS*" "SWANK")))
+ (warn "Your version of Slime does not have *SLIME-REPL-EVAL-HOOKS* so all calls to Gtk+ functions have to be explicit protected by wrapping them in a WITHIN-MAIN-LOOP form"))))))
+
+#-sb-thread
+(defmacro within-main-loop (&body body)
+ `(progn ,@body))
+
+
+
+;;; Generic functions
+
+(defgeneric add-to-radio-group (item1 item2))
+(defgeneric activate-radio-widget (item))
+(defgeneric (setf tool-item-tip-text) (tip-text tool-item))
+(defgeneric (setf tool-item-tip-private) (tip-private tool-item))
+
+
+
+;;; Misc
+
+(defbinding grab-add () nil
+ (widget widget))
+
+(defbinding grab-get-current () widget)
+
+(defbinding grab-remove () nil
+ (widget widget))
+
+(defbinding get-default-language () (copy-of pango:language))
+
+
+;;; About dialog
+
+#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
+(progn
+ (define-callback-marshal %about-dialog-activate-link-callback nil
+ (about-dialog (link string)))
+
+ (defbinding about-dialog-set-email-hook (function) nil
+ (%about-dialog-activate-link-callback callback)
+ ((register-callback-function function) unsigned-int)
+ (user-data-destroy-callback callback))
+
+ (defbinding about-dialog-set-url-hook (function) nil
+ (%about-dialog-activate-link-callback callback)
+ ((register-callback-function function) unsigned-int)
+ (user-data-destroy-callback callback)))
+
+
+;;; Acccel group
+
+(defbinding %accel-group-connect () nil
+ (accel-group accel-group)
+ (key unsigned-int)
+ (modifiers gdk:modifier-type)
+ (flags accel-flags)
+ (gclosure gclosure))
+
+(defun accel-group-connect (group accelerator function &optional flags)
+ (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
+ (let ((gclosure (make-callback-closure function)))
+ (%accel-group-connect group key modifiers flags gclosure)
+ gclosure)))
+
+(defbinding accel-group-connect-by-path (group path function) nil
+ (group accel-group)
+ (path string)
+ ((make-callback-closure function) gclosure :in/return))
+
+(defbinding %accel-group-disconnect (group gclosure) boolean
+ (group accel-group)
+ (gclosure gclosure))
+
+(defbinding %accel-group-disconnect-key () boolean
+ (group accel-group)
+ (key unsigned-int)
+ (modifiers gdk:modifier-type))
+
+(defun accel-group-disconnect (group accelerator)
+ (etypecase accelerator
+ (gclosure (%accel-group-disconnect group accelerator))
+ (string
+ (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
+ (%accel-group-disconnect-key group key modifiers)))))
+
+(defbinding %accel-group-query () (copy-of (vector (inlined accel-group-entry) n))
+ (accel-group accel-group)
+ (key unsigned-int)
+ (modifiers gdk:modifier-type)
+ (n int :out))
+
+(defun accel-group-query (accel-group accelerator)
+ (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
+ (%accel-group-query accel-group key modifiers)))
+
+(defbinding %accel-group-activate () boolean
+ (accel-group accel-group)
+ (acceleratable gobject)
+ (key unsigned-int)
+ (modifiers gdk:modifier-type))
+
+(defun accel-group-activate (accel-group acceleratable accelerator)
+ (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
+ (%accel-group-activate accel-group acceleratable key modifiers)))
+
+(defbinding accel-group-lock () nil
+ (accel-group accel-group))
+
+(defbinding accel-group-unlock () nil
+ (accel-group accel-group))
+
+(defbinding accel-group-from-accel-closure () accel-group
+ (closure gclosure))
+
+(defbinding %accel-groups-activate () boolean
+ (object gobject)
+ (key unsigned-int)
+ (modifiers gdk:modifier-type))
+
+(defun accel-groups-activate (object accelerator)
+ (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
+ (%accel-groups-activate object key modifiers)))
+
+(defbinding accel-groups-from-object () (gslist accel-group)
+ (object gobject))
+
+(defbinding accelerator-valid-p (key &optional modifiers) boolean
+ (key unsigned-int)
+ (modifiers gdk:modifier-type))
+
+(defbinding %accelerator-parse () nil
+ (accelerator string)
+ (key unsigned-int :out)
+ (modifiers gdk:modifier-type :out))
+
+(defgeneric parse-accelerator (accelerator))
+
+(defmethod parse-accelerator ((accelerator string))
+ (multiple-value-bind (key modifiers) (%accelerator-parse accelerator)
+ (if (zerop key)
+ (error "Invalid accelerator: ~A" accelerator)
+ (values key modifiers))))
+
+(defmethod parse-accelerator ((accelerator cons))
+ (destructuring-bind (key modifiers) accelerator
+ (values
+ (etypecase key
+ (integer key)
+ (string
+ (or
+ (gdk:keyval-from-name key)
+ (error "Invalid key name: ~A" key)))
+ (character (parse-accelerator key)))
+ modifiers)))
+
+(defmethod parse-accelerator ((key integer))
+ key)
+
+(defmethod parse-accelerator ((key character))
+ (or
+ (gdk:keyval-from-name (string key))
+ (error "Invalid key name: ~A" key)))
+
+
+(defbinding accelerator-name () string
+ (key unsigned-int)
+ (modifiers gdk:modifier-type))
+
+#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
+(defbinding accelerator-get-label () string
+ (key unsigned-int)
+ (modifiers gdk:modifier-type))
+
+(defbinding %accelerator-set-default-mod-mask () nil
+ (default-modifiers gdk:modifier-type))
+
+(defun (setf accelerator-default-modifier-mask) (default-modifiers)
+ (%accelerator-set-default-mod-mask default-modifiers))
+
+(defbinding (accelerator-default-modifier-mask "gtk_accelerator_get_default_mod_mask") () gdk:modifier-type)
+
+
+;;; Acccel label
+
+(defbinding accel-label-get-accel-width () unsigned-int
+ (accel-label accel-label))
+
+(defbinding accel-label-refetch () boolean
+ (accel-label accel-label))
+
+
+
+;;; Accel map
+
+(defbinding %accel-map-add-entry () nil
+ (path string)
+ (key unsigned-int)
+ (modifiers gdk:modifier-type))
+
+(defun accel-map-add-entry (path accelerator)
+ (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
+ (%accel-map-add-entry path key modifiers)))
+
+(defbinding %accel-map-lookup-entry () boolean
+ (path string)
+ ((make-instance 'accel-key) accel-key :in/return))
+
+(defun accel-map-lookup-entry (path)
+ (multiple-value-bind (found-p accel-key) (%accel-map-lookup-entry path)
+ (when found-p
+ (values
+ (slot-value accel-key 'key)
+ (slot-value accel-key 'modifiers)
+ (slot-value accel-key 'flags)))))
+
+(defbinding %accel-map-change-entry () boolean
+ (path string)
+ (key unsigned-int)
+ (modifiers gdk:modifier-type)
+ (replace boolean))
+
+(defun accel-map-change-entry (path accelerator &optional replace)
+ (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
+ (%accel-map-change-entry path key modifiers replace)))
+
+(defbinding accel-map-load () nil
+ (filename pathname))
+
+(defbinding accel-map-save () nil
+ (filename pathname))
+
+(define-callback-marshal %accel-map-foreach-callback nil
+ ((accel-path string) (key unsigned-int)
+ (modifiers gdk:modifier-type) (changed boolean)) :callback-id :first)
+
+(defbinding %accel-map-foreach (callback-id) nil
+ (callback-id unsigned-int)
+ (%accel-map-foreach-callback callback))
+
+(defbinding %accel-map-foreach-unfiltered (callback-id) nil
+ (callback-id unsigned-int)
+ (%accel-map-foreach-callback callback))
+
+(defun accel-map-foreach (function &optional (filter-p t))
+ (with-callback-function (id function)
+ (if filter-p
+ (%accel-map-foreach id)
+ (%accel-map-foreach-unfiltered id))))
+
+(defbinding accel-map-add-filter () nil
+ (filter string))
+
+(defbinding accel-map-get () accel-map)
+
+(defbinding accel-map-lock-path () nil
+ (path string))
+
+(defbinding accel-map-unlock-path () nil
+ (path string))
+
+
+
+;;; Accessibility
+
+(defbinding accessible-connect-widget-destroyed () nil
+ (accessible accessible))
+
+
+;;; Adjustment
+
+(defmethod initialize-instance ((adjustment adjustment) &key value)
+ (prog1
+ (call-next-method)
+ ;; we need to make sure that the value is set last, otherwise it
+ ;; may be outside current limits and ignored
+ (when value
+ (setf (slot-value adjustment 'value) value))))
+
+
+(defbinding adjustment-changed () nil
+ (adjustment adjustment))
+
+(defbinding adjustment-value-changed () nil
+ (adjustment adjustment))
+
+(defbinding adjustment-clamp-page () nil
+ (adjustment adjustment)
+ (lower single-float)
+ (upper single-float))
+
+
+;;; Alignment
+
+(defbinding alignment-set () nil
+ (alognment alignment)
+ (x-align single-float)
+ (y-align single-float)
+ (x-scale single-float)
+ (y-scale single-float))
+
+(defbinding alignment-get-padding () nil
+ (alognment alignment)
+ (top unsigned-int :out)
+ (bottom unsigned-int :out)
+ (left unsigned-int :out)
+ (right unsigned-int :out))
+
+(defbinding alignment-set-padding () nil
+ (alognment alignment)
+ (top unsigned-int)
+ (bottom unsigned-int)
+ (left unsigned-int)
+ (right unsigned-int))
+
+
+;;; Assistant
+
+#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.10.0")
+(progn
+ (defbinding assistant-get-nth-page () widget
+ (assistant assistant)
+ (page-num int))
+
+ (defbinding %assistant-insert-page () int
+ (assistant assistant)
+ (page widget)
+ (pos int))
+
+ (defun assistant-insert-page (assistant page position &rest child-args)
+ (let ((pos (case position
+ (:first 0)
+ (:last -1)
+ (t position))))
+ (prog1
+ (%assistant-insert-page assistant page pos)
+ (init-child-slots assistant page child-args))))
+
+ (defun assistant-append-page (assistant page &rest child-args)
+ (apply #'assistant-insert-page assistant page :last child-args))
+
+ (defun assistant-prepend-page (assistant page &rest child-args)
+ (apply #'assistant-insert-page assistant page :first child-args))
+
+ (define-callback-marshal %assistant-page-func-callback int
+ ((current-page int)))
+
+ (defbinding assistant-set-forward-page-func (assistant function) nil
+ (assistant assistant)
+ (%assistant-page-func-callback callback)
+ ((register-callback-function function) pointer-data)
+ (user-data-destroy-callback callback))
+
+ (defbinding assistant-add-action-widget () nil
+ (assistant assistant)
+ (child widget))
+
+ (defbinding assistant-remove-action-widget () nil
+ (assistant assistant)
+ (child widget))
+
+ (defbinding assistant-update-buttons-state () nil
+ (assistant assistant)))
+
+
+
+;;; Aspect frame
+
+
+;;; Bin
+
+(defun (setf bin-child) (child bin)
+ (when-bind (current-child (bin-child bin))
+ (container-remove bin current-child))
+ (container-add bin child)
+ child)
+
+(defmethod compute-signal-function ((bin bin) signal function object args)
+ (declare (ignore signal))
+ (if (eq object :child)
+ #'(lambda (bin &rest emission-args)
+ (apply function (bin-child bin) (nconc emission-args args)))
+ (call-next-method)))
+
+
+;;; Box
+
+(defbinding box-pack-start () nil
+ (box box)
+ (child widget)
+ (expand boolean)
+ (fill boolean)
+ (padding unsigned-int))
+
+(defbinding box-pack-end () nil
+ (box box)
+ (child widget)
+ (expand boolean)
+ (fill boolean)
+ (padding unsigned-int))
+
+(defun box-pack (box child &key end (expand t) (fill t) (padding 0))
+ (if end
+ (box-pack-end box child expand fill padding)
+ (box-pack-start box child expand fill padding)))
+
+(defbinding box-reorder-child () nil
+ (box box)
+ (child widget)
+ (position int))
+
+(defbinding box-query-child-packing () nil
+ (box box)
+ (child widget)
+ (expand boolean :out)
+ (fill boolean :out)
+ (padding unsigned-int :out)
+ (pack-type pack-type :out))
+
+(defbinding box-set-child-packing () nil
+ (box box)
+ (child widget)
+ (expand boolean)
+ (fill boolean)
+ (padding unsigned-int)
+ (pack-type pack-type))
+
+
+
+;;; Button
+
+(defmethod initialize-instance ((button button) &rest initargs &key stock)
+ (if stock
+ (apply #'call-next-method button
+ :label stock :use-stock t :use-underline t initargs)
+ (call-next-method)))
+
+
+(defbinding button-pressed () nil
+ (button button))
+
+(defbinding button-released () nil
+ (button button))
+
+(defbinding button-clicked () nil
+ (button button))
+
+(defbinding button-enter () nil
+ (button button))
+
+(defbinding button-leave () nil
+ (button button))
+
+
+
+;;; Calendar
+
+(defbinding calendar-select-month () int
+ (calendar calendar)
+ (month unsigned-int)
+ (year unsigned-int))
+
+(defbinding calendar-select-day () nil
+ (calendar calendar)
+ (day unsigned-int))
+
+(defbinding calendar-mark-day () int
+ (calendar calendar)
+ (day unsigned-int))
+
+(defbinding calendar-unmark-day () int
+ (calendar calendar)
+ (day unsigned-int))
+
+(defbinding calendar-clear-marks () nil
+ (calendar calendar))
+
+(defbinding calendar-get-date () nil
+ (calendar calendar)
+ (year unsigned-int :out)
+ (month unsigned-int :out)
+ (day unsigned-int :out))
+
+(defbinding calendar-freeze () nil
+ (calendar calendar))
+
+(defbinding calendar-thaw () nil
+ (calendar calendar))
+
+
+;;; Check menu item
+
+(defbinding check-menu-item-toggled () nil
+ (check-menu-item check-menu-item))
+
+
+;;; Color selection
+
+(defbinding color-selection-is-adjusting-p () boolean
+ (colorsel color-selection))
+
+(defbinding (color-selection-previous-color
+ "gtk_color_selection_get_previous_color") () nil
+ (colorsel color-selection)
+ ((make-instance 'gdk:color) gdk:color :in/return))
+
+
+;;; Color selection dialog -- no functions
+
+
+
+;;;; Combo Box
+
+(defmethod initialize-instance ((combo-box combo-box) &rest initargs
+ &key model content active)
+ (remf initargs :active)
+ (if model
+ (apply #'call-next-method combo-box initargs)
+ (progn
+ (apply #'call-next-method combo-box
+ :model (make-instance 'list-store :column-types '(string))
+ initargs)
+ (unless (typep combo-box 'combo-box-entry)
+ (let ((cell (make-instance 'cell-renderer-text)))
+ (cell-layout-pack combo-box cell :expand t)
+ (cell-layout-add-attribute combo-box cell :text 0)))))
+ (when content
+ (mapc #'(lambda (text)
+ (combo-box-append-text combo-box text))
+ content))
+ (when active
+ (setf (combo-box-active combo-box) active)))
+
+
+;; (defmethod shared-initialize :after ((combo-box combo-box) names &key active)
+;; (when active
+;; (signal-emit combo-box 'changed)))
+
+(defbinding combo-box-append-text () nil
+ (combo-box combo-box)
+ (text string))
+
+(defbinding combo-box-insert-text () nil
+ (combo-box combo-box)
+ (position int)
+ (text string))
+
+(defbinding combo-box-prepend-text () nil
+ (combo-box combo-box)
+ (text string))
+
+#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
+(defbinding combo-box-get-active-text () (or null string)
+ (combo-box combo-box))
+
+(defbinding combo-box-popup () nil
+ (combo-box combo-box))
+
+(defbinding combo-box-popdown () nil
+ (combo-box combo-box))
+
+
+
+;;;; Combo Box Entry
+
+(defmethod initialize-instance ((combo-box-entry combo-box-entry) &key model)
+ (call-next-method)
+ (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"
+ (cond
+ ((not (numberp id)) id)
+ ((< 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)))
+ (cond
+ (id
+ #'(lambda (dialog response)
+ (when (= response id)
+ (funcall callback dialog))))
+ ((string-equal signal "response")
+ #'(lambda (dialog response)
+ (funcall callback dialog (dialog-find-response dialog response))))
+ (callback))))
+
+(defbinding %dialog-run () int
+ (dialog dialog))
+(defun dialog-run (dialog)
+ (dialog-find-response dialog (%dialog-run 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
+ (setf (widget-can-default-p widget) t)
+ (%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)))
~mdw / clg / blobdiff