X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/7126772159863888c1ab35a0e6eeb6655baab821..72d9260f8258b525339c7241da0631ceaf9f3842:/gtk/gtkwidget.lisp diff --git a/gtk/gtkwidget.lisp b/gtk/gtkwidget.lisp index 142548b..0117544 100644 --- a/gtk/gtkwidget.lisp +++ b/gtk/gtkwidget.lisp @@ -1,5 +1,5 @@ ;; Common Lisp bindings for GTK+ v2.x -;; Copyright 2000-2005 Espen S. Johnsen +;; Copyright 2000-2006 Espen S. Johnsen ;; ;; Permission is hereby granted, free of charge, to any person obtaining ;; a copy of this software and associated documentation files (the @@ -20,11 +20,10 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtkwidget.lisp,v 1.20 2006-02-26 15:24:46 espen Exp $ +;; $Id: gtkwidget.lisp,v 1.32 2008-11-25 22:17:08 espen Exp $ (in-package "GTK") - #-debug-ref-counting (defmethod print-object ((widget widget) stream) (if (and @@ -32,10 +31,11 @@ (defmethod print-object ((widget widget) stream) (slot-boundp widget 'name) (not (zerop (length (widget-name widget))))) (print-unreadable-object (widget stream :type t :identity nil) (format stream "~S at 0x~X" - (widget-name widget) (sap-int (foreign-location widget)))) + (widget-name widget) (pointer-address (foreign-location widget)))) (call-next-method))) (defmethod shared-initialize ((widget widget) names &key (visible nil visible-p)) + (declare (ignore names)) (when (and visible-p (not visible)) ; widget explicit set as not visible (setf (user-data widget 'hidden-p) t) (signal-connect widget 'show @@ -60,29 +60,36 @@ (defmethod slot-unbound ((class gobject-class) (object widget) ((slot-boundp object 'parent) (with-slots (parent child-properties) object (setf child-properties - (make-instance - (gethash (class-of parent) *container-to-child-class-mappings*) + (make-instance (find-child-class (class-of parent)) :parent parent :child object)))) ((call-next-method)))) -(defmethod compute-signal-function ((widget widget) signal function object) - (if (eq object :parent) - #'(lambda (&rest args) - (if (slot-boundp widget 'parent) - (apply function (widget-parent widget) (rest args)) - ;; Delay until parent is set - (signal-connect widget 'parent-set - #'(lambda (old-parent) - (declare (ignore old-parent)) - (let ((*signal-stop-emission* - #'(lambda () - (warn "Ignoring emission stop in delayed signal handler")))) - (apply function (widget-parent widget) (rest args)))) - :remove t) -; (warn "Widget has no parent -- ignoring signal") - )) - (call-next-method))) +(defparameter *widget-display-as-default-in-signal-handler-p* t) + +(defmethod compute-signal-function ((widget widget) signal function object args) + (let ((wrapper + (if (eq object :parent) + #'(lambda (widget &rest emission-args) + (let ((all-args (nconc emission-args args))) + (if (slot-boundp widget 'parent) + (apply function (widget-parent widget) all-args) + ;; Delay until parent is set + (signal-connect widget 'parent-set + #'(lambda (old-parent) + (declare (ignore old-parent)) + (apply #'signal-emit widget signal emission-args)) + :remove t)))) + (call-next-method)))) + (if *widget-display-as-default-in-signal-handler-p* + #'(lambda (widget &rest args) + (let ((display (when (slot-boundp widget 'window) + (gdk:drawable-display (widget-window widget))))) + (gdk:with-default-display (display) + (apply wrapper widget args)))) + wrapper))) + + (defun child-property-value (widget slot) (slot-value (widget-child-properties widget) slot)) @@ -146,12 +153,12 @@ (defbinding widget-queue-resize-no-redraw () nil (defbinding widget-size-request (widget &optional (requisition (make-instance 'requisition))) nil (widget widget) - (requisition requisition :return)) + (requisition requisition :in/return)) (defbinding widget-get-child-requisition (widget &optional (requisition (make-instance 'requisition))) nil (widget widget) - (requisition requisition :return)) + (requisition requisition :in/return)) (defbinding widget-size-allocate () nil (widget widget) @@ -294,17 +301,58 @@ (defbinding widget-shape-combine-mask () nil (x-offset int) (y-offset int)) -(defbinding widget-path () nil - (widget widget) - (path-length int :out) - (path string :out) - (reverse-path string :out)) +(defun widget-path (widget) + (let ((subpath (list (if (and + (slot-boundp widget 'name) + (not (zerop (length (widget-name widget))))) + (widget-name widget) + (type-of widget))))) + (if (slot-boundp widget 'parent) + (nconc (widget-path (widget-parent widget)) subpath) + subpath))) + +(defun widget-class-path (widget) + (let ((subpath (list (type-of widget)))) + (if (slot-boundp widget 'parent) + (nconc (widget-class-path (widget-parent widget)) subpath) + subpath))) + + +(defun widget-path-lookup (path &optional (root (nreverse (window-list-toplevels))) (error-p t)) + (let ((component (first path))) + (loop + for widget in (mklist root) + do (when (or + (and + (stringp component) (slot-boundp widget 'name) + (string= component (widget-name widget))) + (and + (symbolp component) (typep widget component))) + (cond + ((endp (rest path)) (return widget)) + ((typep widget 'container) + (let ((descendant (widget-path-lookup (rest path) (container-children widget) nil))) + (when descendant + (return descendant)))))))) + (when error-p + (error "Widget not found: ~A" path))) + + +(defun widget-find (name &optional (root (nreverse (window-list-toplevels))) (error-p t)) + "Search for a widget with the given name. ROOT should be a container +widget or a list of containers." + (loop + for widget in (mklist root) + do (cond + ((and (slot-boundp widget 'name) (string= name (widget-name widget))) + (return-from widget-find widget)) + ((typep widget 'container) + (let ((descendant (widget-find name (container-children widget) nil))) + (when descendant + (return-from widget-find descendant)))))) + (when error-p + (error "Widget not found: ~A" name))) -(defbinding widget-class-path () nil - (widget widget) - (path-length int :out) - (path string :out) - (reverse-path string :out)) (defbinding widget-modify-style () nil (widget widget) @@ -333,10 +381,12 @@ (defbinding widget-modify-base () nil (state state-type) (color gdk:color)) -(defbinding widget-modify-font () nil +(defbinding widget-modify-font (widget font-desc) nil (widget widget) - (state state-type) - (font-desc pango:font-description)) + ((etypecase font-desc + (pango:font-description font-desc) + (string (pango:font-description-from-string font-desc))) + pango:font-description)) (defbinding widget-create-pango-context () pango:context (widget widget)) @@ -366,9 +416,9 @@ (defbinding widget-queue-draw-area () nil (defbinding widget-reset-shapes () nil (widget widget)) -;; (defbinding widget-set-double-buffered () nil -;; (widget widget) -;; (double-buffered boolean)) +(defbinding widget-set-double-buffered () nil + (widget widget) + (double-buffered boolean)) ;; (defbinding widget-set-redraw-on-allocate () nil ;; (widget widget) @@ -471,12 +521,29 @@ (defbinding widget-remove-mnemonic-label () nil (widget widget) (label widget)) +#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.14.0") +(defbinding widget-get-snapshot () gdk:pixmap + (widget widget) + (clip-rect (or null gdk:rectangle))) + ;;; Additional bindings and functions -(defbinding (widget-mapped-p "gtk_widget_mapped_p") () boolean +(defbinding %widget-flags () int (widget widget)) +(defun widget-flags (widget) + (let ((flags (%widget-flags widget))) + (nconc + (int-to-object-flags flags) + (int-to-widget-flags flags)))) + +(defun widget-mapped-p (widget) + (find :mapped (widget-flags widget))) + +(defun widget-realized-p (widget) + (find :realized (widget-flags widget))) + (defbinding widget-get-size-allocation () nil (widget widget) (width int :out) @@ -486,8 +553,12 @@ (defbinding get-event-widget () widget (event gdk:event)) (defun (setf widget-cursor) (cursor-type widget) - (let ((cursor (make-instance 'gdk:cursor :type cursor-type))) - (gdk:window-set-cursor (widget-window widget) cursor))) + (warn "(SETF WIDGET-CURSOR) is deprecated, use WIDGET-SET-CURSOR instead") + (widget-set-cursor widget cursor-type)) + +(defun widget-set-cursor (widget cursor &rest args) + (gdk:window-set-cursor (widget-window widget) + (apply #'gdk:ensure-cursor cursor args))) (defbinding %widget-get-parent-window () gdk:window (widget widget))