X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/752e7c0d332fefe03865f4aa6d998779e277bef9..19406f20ddb51fdcf94bf9a91c12c53717bad724:/gtk/gtk.lisp diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp index 0f6c40a..38c61bb 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.66 2006/09/14 11:52:40 espen Exp $ +;; $Id: gtk.lisp,v 1.71 2007/06/01 09:17:17 espen Exp $ (in-package "GTK") @@ -48,7 +48,7 @@ "clg 0.93") -;;;; Initalization +;;;; Initalization and display handling (defbinding (gtk-init "gtk_parse_args") () boolean "Initializes the library without opening the display." @@ -58,7 +58,7 @@ (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)) @@ -73,35 +73,46 @@ (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-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 (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."))))) + #+(or cmu sbcl) + (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) + #+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 (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.")) + + (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 @@ -436,11 +447,11 @@ (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))) @@ -670,8 +681,8 @@ (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 @@ -781,6 +792,12 @@ (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 @@ -1068,6 +1085,8 @@ (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)) @@ -1482,10 +1501,14 @@ (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) @@ -1971,12 +1994,16 @@ (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)) @@ -1984,11 +2011,15 @@ (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 @@ -2406,3 +2437,17 @@ (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)))