X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/d314213cd46c74915488718fe22063f5271ce5dc..00485707ad4f321c6a3e73533ff397d549a0efbf:/gtk/gtk.lisp diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp index 5ec601e..ed1a2dc 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.79 2007-07-12 09:02:13 espen Exp $ +;; $Id: gtk.lisp,v 1.84 2007-10-17 16:59:12 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) @@ -552,7 +552,7 @@ (defun assistant-prepend-page (assistant page &rest child-args) (define-callback-marshal %assistant-page-func-callback int ((current-page int))) - (defbinding assistant-set-forward-func (assistant function) nil + (defbinding assistant-set-forward-page-func (assistant function) nil (assistant assistant) (%assistant-page-func-callback callback) ((register-callback-function function) pointer-data) @@ -826,7 +826,7 @@ (defmethod compute-signal-function ((dialog dialog) signal function object args) #'(lambda (dialog response) (when (= response id) (funcall callback dialog)))) - ((eq signal 'response) + ((string-equal signal "response") #'(lambda (dialog response) (funcall callback dialog (dialog-find-response dialog response)))) (callback)))) @@ -1322,7 +1322,7 @@ (defmethod allocate-foreign ((dialog message-dialog) &key (message-type :info) (defmethod shared-initialize ((dialog message-dialog) names &rest initargs - &key buttons text + &key message-type buttons button text #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0") secondary-text) (declare (ignore names)) @@ -1331,6 +1331,13 @@ (defmethod shared-initialize ((dialog message-dialog) names &rest initargs #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0") (when secondary-text (message-dialog-format-secondary-markup dialog secondary-text)) + (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))) @@ -2496,9 +2503,46 @@ (defbinding (stock-set-translate-function "gtk_stock_set_translate_func") ((register-callback-function function) unsigned-int) (user-data-destroy-callback callback))) + +;;; Tooltip + +;; #?-(pkg-exists-p "gtk+-2.0" :atleast-version "2.12.0") +;; (progn +;; (defbinding %tooltip-set-markup () nil +;; tooltip +;; (markup string)) + +;; (defbinding %tooltip-set-text () nil +;; tooltip +;; (text string)) + +;; (defbinding %tooltip-set-icon () nil +;; tooltip +;; (icon gdk:pixbuf)) + +;; (defbinding %tooltip-set-from-stock-icon () nil +;; tooltip +;; (stock-id string) +;; icon-size) + +;; (defbinding %tooltip-set-custom () nil +;; tooltip +;; widget) + +;; (defun tooltip-set (tooltip value &key (markup t) (icon-size :button)) +;; (etypecase value +;; (string (if markup +;; (tooltip-set-markup tooltip value) +;; (tooltip-set-text tooltip value))) +;; (pixbuf (tooltip-set-icon tooltip value)) +;; (keyword (tooltip-set-icon-from-stock tooltip value icon-size)) + -;;; Tooltips +;;; Tooltips + +;; GtkTooltips has been deprecated in favor of the new tooltip API +;; introduced in in GTK+ 2.12 (defbinding tooltips-enable () nil (tooltips tooltips)) @@ -2594,8 +2638,6 @@ (defmethod allocate-foreign ((plug plug) &key id) (%plug-new (or id 0))) -;;;; New stuff in Gtk+ 2.10 - ;;; Link button #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.10.0") @@ -2606,3 +2648,64 @@ (defbinding link-button-set-uri-hook (function) pointer (%link-button-uri-callback callback) ((register-callback-function function) unsigned-int) (user-data-destroy-callback callback))) + + +;;; Builder + +#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.12.0") +(progn + (defmethod initialize-instance ((builder builder) &key interface + (connect-signals t) (package *package*)) + (call-next-method) + (etypecase interface + (null) + (string (builder-add-from-string builder interface)) + (pathname (builder-add-from-file builder interface))) + (when connect-signals + (builder-connect-signals builder package))) + + + (defbinding builder-add-from-file () boolean + builder + pathname + (nil gerror-signal :out)) + + (defbinding builder-add-from-string () boolean + builder + (buffer string) + (-1 int) ; TODO: add gsize type + (nil gerror-signal :out)) + + (defbinding builder-get-object () gobject + builder + (name string)) + + (defbinding builder-get-objects () (gslist gobject) + builder) + + (defun intern-with-package-prefix (name default-package) + (let ((pos (position #\: name))) + (if pos + (intern + (string-upcase (subseq name (1+ pos))) + (string-upcase (subseq name 0 pos))) + (intern (string-upcase name) default-package)))) + + (define-callback %builder-connect-function nil + (builder (object gobject) (signal-name string) (handler-name string) + (connect-object gobject) connect-flags (package user-data-id)) + (format t "Connect signal ~A for ~A to ~A in default package ~A with flags ~A~%" signal-name object handler-name (find-user-data package) connect-flags) + (signal-connect + object signal-name + (intern-with-package-prefix handler-name (find-user-data package)) + :object (or connect-object object) :after (find :after connect-flags))) + + (defbinding %builder-connect-signals-full (builder package) nil + builder + (%builder-connect-function callback) + (package user-data-id)) + + (defun builder-connect-signals (builder &optional (package *package*)) + (with-user-data (id package) + (%builder-connect-signals-full builder id)))) +