X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/3c0ed403b646392e8d08bab78a7f8e1ece9952d2..55376655eb4e84da03c7ce686d9bc10b862068dc:/gtk/gtk.lisp diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp index 7d98710..aec7be5 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.81 2007-07-12 13:55:59 espen Exp $ +;; $Id: gtk.lisp,v 1.96 2008-11-04 20:18:08 espen Exp $ (in-package "GTK") @@ -45,13 +45,17 @@ (defun gtk-version () (format nil "Gtk+ v~A.~A.~A" major minor micro)))) (defun clg-version () - "clg 0.93") + "clg 0.94") ;;;; Initalization and display handling -(defparameter *event-poll-interval* 10000) ; in microseconds +(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." @@ -80,7 +84,7 @@ (defun clg-init-with-threading (&optional display) (clg-init display t)) -#?(sbcl>= 1 0 6) +#?(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))) @@ -98,48 +102,72 @@ (defun socket-status (socket seconds microseconds) :eof)))))) (defun %init-async-event-handling (display) - (let ((style #?(or (featurep :cmu) (sbcl< 1 0 6)) :fd-handler - #?-(or (featurep :cmu) (sbcl< 1 0 6)) nil)) + (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 ~A must be used in combination with asynchronous event handling on this platform. See the README file and for more information." style))) - - #?(or (featurep :cmu) (sbcl< 1 0 6)) + (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 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 - (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)))))))) (setq *periodic-polling-function* #'main-iterate-all) - (setq *max-event-to-sec* 0) - (setq *max-event-to-usec* *event-poll-interval*)) - - #+(and clisp readline) - ;; Readline will call the event hook at most ten times per second - (setf readline:event-hook #'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 :cmu) (sbcl< 1 0 6)) - ;; When running in Slime we need to hook into the Swank server - ;; to handle events asynchronously. - (if (find-package "SWANK") - (let ((read-from-emacs (symbol-function (find-symbol "READ-FROM-EMACS" "SWANK"))) - (stream (funcall (find-symbol "CONNECTION.SOCKET-IO" "SWANK") (symbol-value (find-symbol "*EMACS-CONNECTION*" "SWANK"))))) - (setf (symbol-function (find-symbol "READ-FROM-EMACS" "SWANK")) - #'(lambda () - (loop - (case (socket-status (cons stream :input) 0 *event-poll-interval*) - ((:input :eof) (return (funcall read-from-emacs))) - (otherwise (main-iterate-all))))))) - #-(and clisp readline) - (warn "Asynchronous event handling not supported on this platform. An explicit main loop has to be started.")) + #?(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)) @@ -187,12 +215,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) @@ -205,9 +233,12 @@ (defun %init-multi-threaded-event-handling (display) ;; 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") - (push #'(lambda (form) - (within-main-loop (eval form))) - swank::*slime-repl-eval-hooks*)))) + (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) @@ -552,7 +583,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) @@ -585,8 +616,8 @@ (defun (setf bin-child) (child bin) (defmethod compute-signal-function ((bin bin) signal function object args) (declare (ignore signal)) (if (eq object :child) - #'(lambda (&rest emission-args) - (apply function (bin-child bin) (nconc (rest emission-args) args))) + #'(lambda (bin &rest emission-args) + (apply function (bin-child bin) (nconc emission-args args))) (call-next-method))) @@ -703,10 +734,13 @@ (defbinding check-menu-item-toggled () nil ;;; Color selection -(defbinding (color-selection-is-adjusting-p - "gtk_color_selection_is_adjusting") () boolean +(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 @@ -876,6 +910,7 @@ (defun dialog-add-action-widget (dialog widget &optional (response widget) (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)) @@ -968,6 +1003,10 @@ (defbinding entry-completion-set-match-func (completion function) nil (defbinding entry-completion-complete () nil (completion entry-completion)) +#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.12.0") +(defbinding entry-completion-get-completion-prefix () string + (completion entry-completion)) + #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0") (defbinding entry-completion-insert-prefix () nil (completion entry-completion)) @@ -1661,7 +1700,7 @@ (defun (setf window-default-icon-list) (icons) icons) (defbinding %window-set-default-icon () nil - (icons (glist gdk:pixbuf))) + (icon gdk:pixbuf)) (defgeneric (setf window-default-icon) (icon)) @@ -2371,7 +2410,7 @@ (defbinding %spin-button-spin () nil (defun spin-button-spin (spin-button value) (etypecase value - (real (%spin-button-spin spin-button :spin-user-defined value)) + (real (%spin-button-spin spin-button :user-defined value)) (spin-type (%spin-button-spin spin-button value 0)))) @@ -2503,9 +2542,50 @@ (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-icon-from-stock () nil + tooltip + (stock-id string) + icon-size) + + (defun tooltip-set-icon (tooltip icon &key (size :button)) + (etypecase icon + (gdk:pixbuf (%tooltip-set-icon tooltip icon)) + (string (%tooltip-set-icon-from-stock tooltip icon size)))) + + (defbinding tooltip-set-custom () nil + tooltip + widget) + + (defbinding tooltip-trigger-tooltip-query (&optional (display (gdk:display-get-default))) nil + (display gdk:display)) + + (defbinding tooltip-set-tip-area () nil + tooltip + gdk:rectangle)) + -;;; 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)) @@ -2601,8 +2681,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") @@ -2613,3 +2691,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)))) +