X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/d8dd2e76465c00d5a4519bcc1ca8ef12604a7bf9..72cb3e1f5e112031e8bca6b2238f005d3b87155f:/gtk/gtk.lisp diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp index 5cf18f0..25c6eeb 100644 --- a/gtk/gtk.lisp +++ b/gtk/gtk.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtk.lisp,v 1.76 2007/06/25 10:36:43 espen Exp $ +;; $Id: gtk.lisp,v 1.83 2007/09/06 14:18:56 espen Exp $ (in-package "GTK") @@ -187,12 +187,12 @@ (defun %init-multi-threaded-event-handling (display) (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 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:threads-init) (gdk:with-global-lock (gdk:display-open display) #+win32(gdk:timeout-add-with-lock (/ *event-poll-interval* 1000) @@ -206,8 +206,8 @@ (defun %init-multi-threaded-event-handling (display) ;; This will *only* protect code entered directly in the REPL. (when (find-package "SWANK") (push #'(lambda (form) - (within-main-loop (eval form))) - swank::*slime-repl-eval-hooks*)))) + (within-main-loop (eval form))) + (symbol-value (find-symbol "*SLIME-REPL-EVAL-HOOKS*" "SWANK")))))) #-sb-thread (defmacro within-main-loop (&body body) @@ -329,7 +329,7 @@ (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-groups) +(defbinding accel-groups-from-object () (gslist accel-group) (object gobject)) (defbinding accelerator-valid-p (key &optional modifiers) boolean @@ -521,6 +521,56 @@ (defbinding alignment-set-padding () nil (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 @@ -756,9 +806,10 @@ (defun dialog-response-id (dialog response &optional create-p error-p) (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))) + (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) @@ -770,11 +821,15 @@ (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))) + (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 () nil (dialog dialog)) @@ -1254,11 +1309,20 @@ (defbinding menu-tool-button-set-arrow-tooltip () nil ;;; Message dialog (defmethod allocate-foreign ((dialog message-dialog) &key (message-type :info) - (buttons :close) flags transient-parent) - (%message-dialog-new transient-parent flags message-type buttons)) - - -(defmethod shared-initialize ((dialog message-dialog) names &key text + button buttons flags transient-parent) + (let ((stock-buttons + (cond + ((and (not buttons) (not button)) + (case message-type + (:question :yes-no) + (t :ok))) + ((listp buttons) :none) + (t buttons)))) + (%message-dialog-new transient-parent flags message-type stock-buttons))) + + +(defmethod shared-initialize ((dialog message-dialog) names &rest initargs + &key message-type buttons button text #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0") secondary-text) (declare (ignore names)) @@ -1267,7 +1331,16 @@ (defmethod shared-initialize ((dialog message-dialog) names &key text #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0") (when secondary-text (message-dialog-format-secondary-markup dialog secondary-text)) - (call-next-method)) + (when (and (not buttons) (not button)) + (loop + for (key value) on initargs by #'cddr + when (and (eq key :signal) (eq (first value) :close)) + do (warn "Default button configuration changed from ~A to ~A" :close + (if (eq message-type :question) :yes-no :ok)) + (loop-finish))) + (if (typep buttons 'buttons-type) + (apply #'call-next-method dialog names (plist-remove :buttons initargs)) + (call-next-method))) (defbinding %message-dialog-new () pointer