;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gtkwidget.lisp,v 1.11 2004-12-17 00:27:01 espen Exp $
+;; $Id: gtkwidget.lisp,v 1.14 2005-01-06 21:00:51 espen Exp $
(in-package "GTK")
(defmethod slot-unbound ((class gobject-class) (object widget) slot)
(cond
- ((and (eq slot 'child-slots) (slot-value object 'parent))
- (with-slots (parent child-slots) object
+ ((and (eq slot 'child-properties) (slot-value object 'parent))
+ (with-slots (parent child-properties) object
(setf
- child-slots
+ child-properties
(make-instance
(gethash (class-of parent) *container-to-child-class-mappings*)
:parent parent :child object))))
(t (call-next-method))))
-
-(defun child-slot-value (widget slot)
- (slot-value (widget-child-slots widget) slot))
-
-(defun (setf child-slot-value) (value widget slot)
- (setf (slot-value (widget-child-slots widget) slot) value))
-
-(defmacro with-child-slots (slots widget &body body)
- `(with-slots ,slots (widget-child-slots ,widget)
+(defmethod create-callback-function ((widget widget) function arg1)
+ (if (eq arg1 :parent)
+ #'(lambda (&rest args)
+ (if (slot-boundp widget 'parent)
+ (apply function (widget-parent widget) (rest args))
+ (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)))
+
+(defun child-property-value (widget slot)
+ (slot-value (widget-child-properties widget) slot))
+
+(defun (setf child-property-value) (value widget slot)
+ (setf (slot-value (widget-child-properties widget) slot) value))
+
+(defmacro with-child-properties (slots widget &body body)
+ `(with-slots ,slots (widget-child-properties ,widget)
,@body))
(event gdk:event))
(defun (setf widget-cursor) (cursor-type widget)
- (let ((cursor (make-instance 'cursor :type cursor-type)))
+ (let ((cursor (make-instance 'gdk:cursor :type cursor-type)))
(gdk:window-set-cursor (widget-window widget) cursor)))