X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/050f6c9f2af72fa8a1114b02e823118ef258e08a..b808fe1b5894a080e0cd7ee7bfdf136eb8b2d693:/gtk/gtk.lisp diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp index 80725a4..6fb06ff 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.73 2007-06-19 11:32:25 espen Exp $ +;; $Id: gtk.lisp,v 1.83 2007-09-06 14:18:56 espen Exp $ (in-package "GTK") @@ -74,7 +74,7 @@ (%init-async-event-handling display) #+sb-thread(%init-multi-threaded-event-handling display) #-sb-thread(error "Multi threading not supported on this platform"))) - (gdk:find-display display)) + (gdk:ensure-display display t)) (defun clg-init-with-threading (&optional display) (clg-init display t)) @@ -88,12 +88,14 @@ (sb-unix:fd-zero read-fds) (sb-unix:fd-set fd read-fds) - (unless (zerop (sb-unix:unix-fast-select - (1+ fd) (sb-alien:addr read-fds) nil nil - seconds microseconds)) - (if (peek-char nil (car socket) nil) - :input - :eof))))) + (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)) :fd-handler @@ -185,12 +187,12 @@ (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) @@ -204,8 +206,8 @@ ;; 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) @@ -327,7 +329,7 @@ (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 @@ -519,6 +521,56 @@ (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 @@ -754,9 +806,10 @@ (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) @@ -768,11 +821,15 @@ (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)) @@ -1252,11 +1309,20 @@ ;;; 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)) @@ -1265,7 +1331,16 @@ #?(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 @@ -1358,7 +1433,7 @@ (prog1 (if display (apply #'call-next-method - window :screen (gdk:display-get-default-screen display) initargs) + window :screen (gdk:display-get-default-screen (gdk:ensure-display display)) initargs) (call-next-method)) (initial-add window #'window-add-accel-group initargs :accel-group :accel-groups))) @@ -1400,13 +1475,14 @@ (defbinding %window-set-geometry-hints () nil (window window) + (widget (or widget null)) (geometry gdk:geometry) (geometry-mask gdk:window-hints)) -(defun window-set-geometry-hints (window &key min-width min-height +(defun window-set-geometry-hints (window &key widget min-width min-height max-width max-height base-width base-height - width-inc height-inc min-aspect max-aspect - (gravity nil gravity-p) min-size max-size) + width-inc height-inc gravity + aspect (min-aspect aspect) (max-aspect aspect)) (let ((geometry (make-instance 'gdk:geometry :min-width (or min-width -1) :min-height (or min-height -1) @@ -1417,12 +1493,11 @@ :width-inc (or width-inc 0) :height-inc (or height-inc 0) :min-aspect (or min-aspect 0) - :max-aspect (or max-aspect 0) - :gravity gravity)) + :max-aspect (or max-aspect 0))) (mask ())) - (when (or min-size min-width min-height) + (when (or min-width min-height) (push :min-size mask)) - (when (or max-size max-width max-height) + (when (or max-width max-height) (push :max-size mask)) (when (or base-width base-height) (push :base-size mask)) @@ -1430,9 +1505,10 @@ (push :resize-inc mask)) (when (or min-aspect max-aspect) (push :aspect mask)) - (when gravity-p - (push :win-gravity mask)) - (%window-set-geometry-hints window geometry mask))) + (when gravity + (push :win-gravity mask) + (setf (gdk:geometry-gravity geometry) gravity)) + (%window-set-geometry-hints window widget geometry mask))) (defbinding window-list-toplevels () (glist (copy-of window)) "Returns a list of all existing toplevel windows.")