X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/904a03a935a44f0cc6f2b145faab3eace05bd7ae..80c00d73e8060c5a7cb8944e20c1412646e0796e:/gtk/gtk.lisp diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp index 3a6174f..01f6ff3 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.64 2006-06-30 10:57:21 espen Exp $ +;; $Id: gtk.lisp,v 1.72 2007-06-04 19:03:12 espen Exp $ (in-package "GTK") @@ -48,7 +48,7 @@ (defun clg-version () "clg 0.93") -;;;; Initalization +;;;; Initalization and display handling (defbinding (gtk-init "gtk_parse_args") () boolean "Initializes the library without opening the display." @@ -58,44 +58,69 @@ (defbinding (gtk-init "gtk_parse_args") () boolean (defparameter *event-poll-interval* 10000) (defun clg-init (&optional display) - "Initializes the system and starts the event handling" + "Initializes the system and starts event handling" #+sbcl(when (and (find-package "SWANK") (eq (symbol-value (find-symbol "*COMMUNICATION-STYLE*" "SWANK")) :spawn)) (error "When running clg in Slime the communication style :spawn can not be used. See the README file and for more information.")) (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.")) - (prog1 - (gdk:display-open display) - #+(or cmu sbcl) - (progn - (add-fd-handler (gdk:display-connection-number) :input #'main-iterate-all) - (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) - #+clisp - ;; When running in Slime we need to hook into the Swank server - ;; to handle events asynchronously - (if (find-symbol "WAIT-UNTIL-READABLE" "SWANK") - (setf (symbol-function 'swank::wait-until-readable) - #'(lambda (stream) + #?(or (pkg-config:featurep :cmu) (and (pkg-config:featurep :sbcl) (not (pkg-config:sbcl>= 1 0 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*)) + #?(pkg-config:sbcl>= 1 0 6) + (warn "Periodic polling functionality has been removed from SERVE-EVENT in SBCL 1.0.6. An explicit gtk main loop has to be invoked.") + #+(and clisp readline) + ;; Readline will call the event hook at most ten times per second + (setf readline:event-hook #'main-iterate-all) + #+clisp + ;; 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:socket-status (cons stream :input) 0 *event-poll-interval*) - (:input (return t)) + (:input (return (funcall read-from-emacs))) (:eof (read-char stream)) - (otherwise (main-iterate-all)))))) - #-readline(warn "Not running in Slime and Readline support is missing, so the Gtk main loop has to be invoked explicit."))))) + (otherwise (main-iterate-all))))))) + #-readline(warn "Not running in Slime and Readline support is missing, so the Gtk main loop has to be invoked explicit.")) + + (gdk:display-open display))) + #+sbcl (defun clg-init-with-threading (&optional display) - "Initializes the system and starts the event handling" + "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) (gdk:threads-set-lock-functions) (unless (gtk-init) @@ -424,11 +449,11 @@ (defun (setf bin-child) (child bin) (container-add bin child) child) -(defmethod compute-signal-function ((bin bin) signal function object) +(defmethod compute-signal-function ((bin bin) signal function object args) (declare (ignore signal)) (if (eq object :child) - #'(lambda (&rest args) - (apply function (bin-child bin) (rest args))) + #'(lambda (&rest emission-args) + (apply function (bin-child bin) (nconc (rest emission-args) args))) (call-next-method))) @@ -658,8 +683,8 @@ (defmethod compute-signal-id ((dialog dialog) signal) (ensure-signal-id 'response dialog) (call-next-method))) -(defmethod compute-signal-function ((dialog dialog) signal function object) - (declare (ignore function object)) +(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 @@ -769,6 +794,12 @@ (defmethod (setf container-children) (children (dialog dialog)) (setf (container-children (dialog-vbox dialog)) children)) +;;; Drawing Area + +(defun drawing-area-scroll (drawing-area dx dy) + (gdk:window-scroll (widget-window drawing-area) dx dy)) + + ;;; Entry (defbinding entry-get-layout-offsets () nil @@ -1056,6 +1087,8 @@ (defun %add-activate-callback (widget signal function object after) (defmethod activate-radio-widget ((button radio-button)) (signal-emit button 'clicked)) +(defgeneric add-activate-callback (action function &key object after)) + (defmethod add-activate-callback ((button radio-button) function &key object after) (%add-activate-callback button 'clicked function object after)) @@ -1470,10 +1503,14 @@ (defun (setf window-default-icon-list) (icons) (defbinding %window-set-default-icon () nil (icons (glist gdk:pixbuf))) +(defgeneric (setf window-default-icon) (icon)) + (defmethod (setf window-default-icon) ((icon gdk:pixbuf)) (%window-set-default-icon icon) icon) +(defgeneric (setf window-group) (group window)) + (defmethod (setf window-group) ((group window-group) (window window)) (window-group-add-window group window) group) @@ -1959,12 +1996,16 @@ (defbinding %table-set-col-spacings () nil (table table) (spacing unsigned-int)) -(defun (setf table-col-spacing) (spacing table &optional col) - (if col - (%table-set-col-spacing table col spacing) +(defun (setf table-column-spacing) (spacing table &optional column) + (if column + (%table-set-col-spacing table column spacing) (%table-set-col-spacings table spacing)) spacing) +(defun (setf table-col-spacing) (spacing table &optional col) + (warn "TABLE-COL-SPACING is deprecatet, use TABLE-COLUMN-SPACING instead") + (setf (table-column-spacing table col) spacing)) + (defbinding %table-get-col-spacing () unsigned-int (table table) (col unsigned-int)) @@ -1972,11 +2013,15 @@ (defbinding %table-get-col-spacing () unsigned-int (defbinding %table-get-default-col-spacing () unsigned-int (table table)) -(defun table-col-spacing (table &optional col) - (if col - (%table-get-col-spacing table col) +(defun table-column-spacing (table &optional column) + (if column + (%table-get-col-spacing table column) (%table-get-default-col-spacing table))) +(defun table-col-spacing (table &optional col) + (warn "TABLE-COL-SPACING is deprecatet, use TABLE-COLUMN-SPACING instead") + (table-column-spacing table col)) + ;;; Toolbar @@ -2394,3 +2439,17 @@ (defbinding %plug-new () pointer (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") +(progn + (define-callback-marshal %link-button-uri-callback nil (link-button (link string))) + + (defbinding link-button-set-uri-hook (function) pointer + (%link-button-uri-callback callback) + ((register-callback-function function) unsigned-int) + (user-data-destroy-callback callback)))