;; 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.26 2007-01-07 20:23:22 espen Exp $
+;; $Id: gtkwidget.lisp,v 1.29 2007-09-06 14:27:07 espen Exp $
(in-package "GTK")
-
#-debug-ref-counting
(defmethod print-object ((widget widget) stream)
(if (and
((call-next-method))))
+(defparameter *widget-display-as-default-in-signal-handler-p* t)
+
(defmethod compute-signal-function ((widget widget) signal function object args)
- (declare (ignore signal))
- (if (eq object :parent)
- #'(lambda (&rest emission-args)
- (let ((all-args (nconc (rest 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))
- (let ((*signal-stop-emission*
- #'(lambda ()
- (warn "Ignoring emission stop in delayed signal handler"))))
- (apply function (widget-parent widget) all-args)))
- :remove t)
-; (warn "Widget has no parent -- ignoring signal")
- )))
- (call-next-method)))
+ (let ((wrapper
+ (if (eq object :parent)
+ #'(lambda (&rest emission-args)
+ (let ((all-args (nconc (rest 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 (rest emission-args)))
+ :remove t))))
+ (call-next-method))))
+ (if *widget-display-as-default-in-signal-handler-p*
+ #'(lambda (&rest args)
+ (let ((display (when (slot-boundp widget 'window)
+ (gdk:drawable-display (widget-window widget)))))
+ (gdk:with-default-display (display)
+ (apply wrapper args))))
+ wrapper)))
+
+
(defun child-property-value (widget slot)
(slot-value (widget-child-properties widget) slot))
(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)
;;; 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)