repos / qt.gui / annotate_shade
summary | shortlog | log | tree | commit | commitdiff | headdiff | annotate | filehistory
normal | plain | shade | zebra
Rework QObject parent ownership transfer
Annotate for file src/object.lisp
2009-06-11 tobias 1 (in-package :qt)
2010-01-10 tobias 2
2009-06-11 tobias 3 (let ((object (make-instance 'object)))
14:59:48 ' 4 (defmethod cxx:static-meta-object ((class (eql (find-class 'object))))
2009-07-02 tobias 5 "No OBJECT.STATIC-META-OBJECT (r558420)."
19:12:45 ' 6 (cxx:meta-object object))
2009-05-31 tobias 7 (defmethod cxx:static-meta-object ((class cxx:class))
2009-07-02 tobias 8 (cxx:static-meta-object (smoke::find-smoke-class class))))
2010-01-10 tobias 9
2009-05-31 tobias 10 (defmethod documentation :around ((class cxx:class)
2009-06-11 tobias 11 (doc-type t))
14:59:48 ' 12 (if (and (subtypep class (find-class 'object))
2009-05-31 tobias 13 (not (subtypep class (find-class 'cxx:class))))
2010-01-10 tobias 14 (format nil "~@[~A~%~]Properties:~%~T~{~<~%~T~0,75:; ~(~A~)~>~}
08:52:49 ' 15
' 16 Signals:
' 17 ~{~T~A~%~}
' 18 Slots:
' 19 ~{~T~A~%~}"
2009-06-11 tobias 20 (call-next-method) (sort (class-properties class) #'string<=)
2010-01-10 tobias 21 (sort (class-signals class) #'string<=)
08:52:49 ' 22 (sort (class-slots class) #'string<=))
' 23 (call-next-method)))
' 24
2009-06-11 tobias 25 (defmethod print-object ((object object) stream)
2010-01-10 tobias 26 (if (or (not (slot-boundp object 'pointer))
08:52:49 ' 27 (null-pointer-p (pointer object)))
' 28 (call-next-method)
2009-08-02 tobias 29 (print-unreadable-object (object stream :type t :identity t)
11:29:13 ' 30 (princ (cxx:object-name object) stream))))
2010-01-10 tobias 31
08:52:49 ' 32 (defun meta-object-methods (meta-object &optional (direct-only nil))
' 33 (loop for index from (if direct-only (cxx:method-offset meta-object) 0)
' 34 below (cxx:method-count meta-object)
' 35 collect (cxx:method meta-object index)))
' 36
' 37
2009-06-11 tobias 38 (defun meta-object-signals (meta-object)
2010-01-10 tobias 39 (mapcar #'cxx:signature
08:52:49 ' 40 (remove-if-not #'(lambda (m) (enum= qt:meta-method.+signal+
' 41 (cxx:method-type m)))
2009-06-11 tobias 42 (meta-object-methods meta-object))))
2010-01-10 tobias 43
2009-06-11 tobias 44 (defun class-signals (class)
14:59:48 ' 45 (meta-object-signals (cxx:static-meta-object class)))
2010-01-10 tobias 46
2009-06-11 tobias 47 (defun meta-object-slots (meta-object)
2010-01-10 tobias 48 (mapcar #'cxx:signature
08:52:49 ' 49 (remove-if-not #'(lambda (m) (enum= qt:meta-method.+slot+
' 50 (cxx:method-type m)))
2009-06-11 tobias 51 (meta-object-methods meta-object))))
2010-01-10 tobias 52
08:52:49 ' 53
2009-06-11 tobias 54 (defun class-slots (class)
14:59:48 ' 55 (meta-object-slots (cxx:static-meta-object class)))
2010-01-10 tobias 56
08:52:49 ' 57
2009-06-11 tobias 58 (defmethod initialize-instance :after ((object object)
2009-06-11 tobias 59 &key pointer &allow-other-keys)
2010-01-10 tobias 60 "Registers the object to the parent when a parent was set in the constructor
08:52:49 ' 61 and the objects metaclass is SMOKE-WRAPPER-CLASS."
2009-06-11 tobias 62 (when (and (null pointer)
2010-01-10 tobias 63 (null-pointer-p (smoke::pointer object)))
08:52:49 ' 64 (error "Object ~A has not been constructed" object))
' 65 (when (and (null pointer)
' 66 (not (null-pointer-p (smoke::pointer object)))
2009-05-31 tobias 67 ; (typep (class-of object) 'cxx:class)
2009-06-11 tobias 68 (not (null-pointer-p (smoke::pointer (cxx:parent object)))))
2009-05-31 tobias 69 (smoke::disown-object object)))
2010-01-10 tobias 70
08:52:49 ' 71 (define-condition wrapper-gc (storage-condition)
2009-08-02 tobias 72 ((class-name :initarg :class-name
11:15:21 ' 73 :documentation "The class name of the gc'ed object.")
2010-01-10 tobias 74 (pointer :initarg :pointer))
08:52:49 ' 75 (:report (lambda (condition stream)
2009-05-31 tobias 76 (format stream "The object ~A ~A of type cxx:class
2009-08-02 tobias 77 has a parent but got garbage collected."
11:15:21 ' 78 (slot-value condition 'class-name)
' 79 (slot-value condition 'pointer)))))
2010-01-10 tobias 80
2009-08-02 tobias 81 (smoke:eval-startup (:compile-toplevel :execute)
2009-07-22 tobias 82 (defparameter *get-parent*
2009-06-21 tobias 83 (smoke::make-smoke-method (smoke::make-smoke-class
09:29:25 ' 84 *qt-smoke*
' 85 "QObject")
' 86 "parent"))
2009-07-22 tobias 87 ;; FIXME this leaks memory when QCoreApplication::exec is never called,
22:21:01 ' 88 ;; beause then, deleteLater has no effect.
' 89 (defparameter *delete-later*
2009-06-21 tobias 90 (smoke::make-smoke-method (smoke::make-smoke-class
09:29:25 ' 91 *qt-smoke*
' 92 "QObject")
' 93 "deleteLater")))
2009-06-10 tobias 94
2009-05-31 tobias 95 (defun print-object-to-string (object)
17:33:32 ' 96 (with-output-to-string (stream)
' 97 (print-object object stream)))
' 98
' 99 (defmethod smoke::make-finalize ((object object))
2009-06-21 tobias 100 "Delete the qt:object OBJECT,
2010-01-10 tobias 101 by calling cxx:delete-later iff it has no parent."
2009-06-21 tobias 102 (let ((pointer (pointer object))
2009-05-31 tobias 103 (class (class-of object))
2009-06-21 tobias 104 (next (call-next-method)))
2009-05-31 tobias 105 (if (typep (class-of object) 'cxx:class)
2009-06-21 tobias 106 #'(lambda ()
09:29:25 ' 107 (handler-case
' 108 (if (null-pointer-p (smoke::pointer-call *get-parent* pointer))
' 109 (smoke::pointer-call *delete-later* pointer)
2009-06-10 tobias 110 (error (make-condition 'wrapper-gc :class-name name
2009-06-21 tobias 111 :pointer pointer)))
2009-05-31 tobias 112 (error (condition)
17:33:32 ' 113 (smoke::report-finalize-error condition "qt:object wrap"
' 114 (name class) pointer))))
2009-06-21 tobias 115 #'(lambda ()
09:29:25 ' 116 (handler-case
2009-05-31 tobias 117 (if (null-pointer-p (smoke::pointer-call *get-parent* pointer))
17:33:32 ' 118 (funcall next)
' 119 (cerror 'continue "Finalizer for object with a parent called."))
' 120 (error (condition)
' 121 (smoke::report-finalize-error condition "qt:object"
' 122 (name class) pointer)))))))
2010-01-10 tobias 123
08:52:49 ' 124 ;;;
2009-07-22 tobias 125 ;;; The event-notify callback get called by QCoreApplication,
22:21:01 ' 126 ;;; on notification of an event.
2010-01-10 tobias 127 ;;;
2009-07-22 tobias 128 ;;; The DATA argument is an array of size three, containing the pointers:
2010-01-10 tobias 129 ;;; void* receiver
08:52:49 ' 130 ;;; void* event
' 131 ;;; void* result
' 132 ;;; in that order.
' 133 ;;;
' 134 ;;; Returning true marks the event as handled; false on the other hand
' 135 ;;; leaves the event processing unchanged.
' 136 ;;;
2009-07-22 tobias 137 ;;; See: QCoreApplication::notifyInternal(QObject *receiver, QEvent *event)
2010-01-10 tobias 138
08:52:49 ' 139 (cffi:defcallback event-notify smoke:cxx-bool
' 140 ((data :pointer))
' 141 (declare (optimize (speed 3)))
2009-05-31 tobias 142 (let ((event (make-instance 'event :pointer (cffi:mem-aref data :pointer 1))))
2010-01-10 tobias 143 (enum-case (cxx:type event)
2009-06-11 tobias 144 (event.+child-added+
2009-06-10 tobias 145 (let* ((child-event (make-instance 'child-event
2009-08-02 tobias 146 :pointer
2009-05-31 tobias 147 (smoke::upcast event (find-class 'child-event)))))
17:33:32 ' 148 (smoke::disown-object (cxx:child child-event))))
2009-06-11 tobias 149 (event.+child-removed+
14:59:48 ' 150 (let* ((child-event (make-instance 'child-event
2009-08-02 tobias 151 :pointer (smoke::upcast event
2009-05-31 tobias 152 (find-class 'child-event)))))
17:33:32 ' 153 ;; We receive child removed events for any QObject, wherter
' 154 ;; it was construted by Smoke or not. Only take ownership of objects
' 155 ;; that have been constructed by Smoke.
' 156 (when (smoke::has-pointer-p (smoke::pointer (cxx:child child-event)))
' 157 (smoke::take-ownership (cxx:child child-event)))))))
2010-01-10 tobias 158 nil)
08:52:49 ' 159
' 160 (eval-when (:compile-toplevel :load-toplevel :execute)
' 161 (cffi:defcfun qt-smoke-register-event-notify :boolean
' 162 (event-notify :pointer)))
' 163
' 164 (defun register-event-notify ()
' 165 (let ((ret (qt-smoke-register-event-notify (cffi:callback event-notify))))
' 166 (unless ret
2009-06-21 tobias 167 (error "The event-notify callback table is full."))))
2010-01-10 tobias 168
2009-08-02 tobias 169 (smoke:eval-startup ()
2010-01-10 tobias 170 (register-event-notify))
Crece desde el pueblo el futuro / crece desde el pie