repos / qt.gui / annotate_shade
summary | shortlog | log | tree | commit | commitdiff | headdiff | annotate | filehistory
normal | plain | shade | zebra
Support ownership transfer to non smoke wrapped QObjects & cleanup C++ to Lisp translation.
Annotate for file src/object.lisp
2010-01-10 tobias 1 (in-package :cl-smoke.qt-impl)
08:52:49 ' 2
2009-08-02 tobias 3 ;; Smoke always calls the method of the class the object is assumed to
11:15:21 ' 4 ;; be and not the most specific method like required for virtual
' 5 ;; methods. Thus we implement a virtual metaObject() method to
' 6 ;; determine the actual class. This is only needed for objects not
' 7 ;; constructed by Smoke, since otherwise we would know the most
' 8 ;; specific class.
' 9 (defcfun qt-smoke-meta-object :pointer (object :pointer))
' 10 (defun meta-object (object)
' 11 (make-instance 'qt:meta-object
' 12 :pointer (qt-smoke-meta-object (pointer object))))
' 13
' 14 (eval-startup (:load-toplevel :compile-toplevel :execute)
2009-08-27 tobias 15 (let ((object (make-instance 'qt:object)))
08:37:36 ' 16 (defmethod cxx:static-meta-object ((class (eql (find-class 'qt:object))))
' 17 "No OBJECT.STATIC-META-OBJECT (r558420)."
' 18 (cxx:meta-object object))))
' 19
2010-01-10 tobias 20 (defmethod cxx:static-meta-object ((class cxx:class))
08:52:49 ' 21 (cxx:static-meta-object (smoke::find-smoke-class class)))
' 22
' 23 (defmethod documentation :around ((class smoke::smoke-standard-class)
' 24 (doc-type (eql 't)))
' 25 (if (and (subtypep class (find-class 'qt:object))
' 26 (not (subtypep class (find-class 'cxx:class))))
' 27 (format nil "~@[~A~%~]Properties:~%~T~{~<~%~T~0,75:; ~(~A~)~>~}
' 28
' 29 Signals:
' 30 ~{~T~A~%~}
' 31 Slots:
' 32 ~{~T~A~%~}"
' 33 (call-next-method) (sort (qt:class-direct-properties class) #'string<=)
' 34 (sort (class-signals class) #'string<=)
' 35 (sort (class-slots class) #'string<=))
' 36 (call-next-method)))
' 37
' 38 (defmethod print-object ((object qt:object) stream)
' 39 (if (or (not (slot-boundp object 'pointer))
' 40 (null-pointer-p (pointer object)))
' 41 (call-next-method)
2009-08-02 tobias 42 (print-unreadable-object (object stream :type t :identity t)
11:29:13 ' 43 (princ (cxx:object-name object) stream))))
2010-01-10 tobias 44
08:52:49 ' 45 (defun meta-object-methods (meta-object &optional (direct-only nil))
' 46 (loop for index from (if direct-only (cxx:method-offset meta-object) 0)
' 47 below (cxx:method-count meta-object)
' 48 collect (cxx:method meta-object index)))
' 49
' 50
' 51 (defun meta-object-signals (meta-object &key all)
' 52 (mapcar #'cxx:signature
' 53 (remove-if-not #'(lambda (m) (enum= qt:meta-method.+signal+
' 54 (cxx:method-type m)))
' 55 (meta-object-methods meta-object (not all)))))
' 56
' 57 (defun class-signals (class &key all)
' 58 (meta-object-signals (cxx:static-meta-object class) :all all))
' 59
' 60 (defun meta-object-slots (meta-object &key all)
' 61 (mapcar #'cxx:signature
' 62 (remove-if-not #'(lambda (m) (enum= qt:meta-method.+slot+
' 63 (cxx:method-type m)))
' 64 (meta-object-methods meta-object (not all)))))
' 65
' 66
' 67 (defun class-slots (class &key all)
' 68 (meta-object-slots (cxx:static-meta-object class) :all all))
' 69
' 70 (defun parent-p (object)
2009-08-02 tobias 71 (not (null-pointer-p (smoke::pointer-call
11:15:21 ' 72 (smoke::make-smoke-method-from-name
' 73 (find-class 'qt:object)
' 74 "parent")
' 75 (smoke::pointer object)))))
' 76
2010-01-10 tobias 77
2009-08-02 tobias 78 ;; FIXME this might not be that smart.
11:15:21 ' 79 (eval-startup ()
' 80 (defparameter *destroyed-slot* (qt:make-slot
' 81 #'(lambda (object)
' 82 (foreign-funcall-pointer
' 83 (get-callback 'smoke::destructed)
' 84 () :pointer (smoke:pointer object))))))
' 85
' 86 (defun ensure-smoke-parent (object)
2010-01-10 tobias 87 (declare (optimize (speed 3)))
08:52:49 ' 88 (let ((parent (cxx:parent object)))
2009-08-02 tobias 89 (assert (not (null-pointer-p (smoke:pointer parent)))
11:15:21 ' 90 ()
' 91 "The object ~A has not parent." object)
' 92 (unless (smoke::has-pointer-p (smoke:pointer parent))
' 93 ;; Before we ADD-OBJECT PARENT it must know its real class to
' 94 ;; prevent a clash when the same pointer is returned by a
' 95 ;; function with a more specific type.
' 96 (change-class parent
' 97 ;; Note: there can be classes that are not known
' 98 ;; to Smoke, like KDE's OxygenStyle that might
' 99 ;; be seen by the event-notify callback. But
' 100 ;; it's probably save to assume the user will
' 101 ;; never use those.
' 102 (let ((class-name (cxx:class-name (meta-object parent))))
' 103 (smoke::lispify class-name (ecase (char class-name 0)
' 104 (#\Q :qt)
' 105 (#\K :kde)))))
' 106 (smoke::add-object parent)
' 107 (qt:connect (qt:get-signal parent "destroyed(QObject*)")
' 108 *destroyed-slot* qt:+direct-connection+)
' 109 (tg:cancel-finalization parent)
' 110 (smoke::transfer-ownership-to parent (ensure-smoke-parent parent)))
' 111 parent))
2010-01-10 tobias 112
08:52:49 ' 113 (defmethod initialize-instance :after ((object qt:object)
' 114 &key (pointer nil pointer-p) &allow-other-keys)
' 115 "Registers the object to the parent when a parent was set in the constructor
' 116 and the objects metaclass is SMOKE-WRAPPER-CLASS."
' 117 (declare (optimize (speed 3)))
' 118 (when (and (not pointer-p)
' 119 (null-pointer-p (smoke::pointer object)))
' 120 (error "Object ~A has not been constructed" object))
' 121 (when (and (null pointer)
' 122 (not (null-pointer-p (smoke::pointer object)))
' 123 (parent-p object))
' 124 (smoke::transfer-ownership-to object
2009-08-02 tobias 125 (ensure-smoke-parent object))))
2010-01-10 tobias 126
08:52:49 ' 127 (define-condition wrapper-gc (storage-condition)
2009-08-02 tobias 128 ((object-class :initarg :object-class
11:15:21 ' 129 :documentation "The class of the gc'ed object.")
2010-01-10 tobias 130 (pointer :initarg :pointer))
08:52:49 ' 131 (:report (lambda (condition stream)
2009-08-02 tobias 132 (format stream "The object ~A ~A of type cxx:class
11:15:21 ' 133 has the parent but got garbage collected."
' 134 (slot-value condition 'object-class)
' 135 (slot-value condition 'pointer)))))
2010-01-10 tobias 136
2009-08-02 tobias 137 (eval-startup (:compile-toplevel :execute)
2010-01-10 tobias 138 (defparameter *get-parent*
08:52:49 ' 139 (smoke::make-smoke-method-from-name (find-class 'qt:object) "parent"))
' 140
' 141 ;; FIXME this leaks memory when QCoreApplication::exec() is never
' 142 ;; called, beause then, deleteLater() has no effect.
' 143 (defparameter *delete-later*
' 144 (smoke::make-smoke-method-from-name (find-class 'qt:object) "deleteLater")))
' 145
' 146 (defmethod smoke::make-finalize ((object qt:object))
' 147 "Delete the qt:object OBJECT,
' 148 by calling cxx:delete-later iff it has no parent."
' 149 (let ((pointer (pointer object))
' 150 (class (class-of object))
' 151 (next (call-next-method)))
' 152 (declare (function next))
' 153 (if (typep (class-of object) 'cxx:class)
' 154 #'(lambda ()
' 155 (declare (optimize (speed 3)))
' 156 (handler-case
' 157 (if (null-pointer-p (smoke::pointer-call *get-parent* pointer))
' 158 (smoke::pointer-call *delete-later* pointer)
' 159 (error (make-condition 'wrapper-gc
2009-08-02 tobias 160 :object-class class
2010-01-10 tobias 161 :pointer pointer)))
08:52:49 ' 162 (error (condition)
' 163 (smoke::report-finalize-error condition "qt:object wrap"
' 164 (name class) pointer))))
' 165 #'(lambda ()
' 166 (declare (optimize (speed 3)))
' 167 (handler-case
' 168 (if (null-pointer-p (smoke::pointer-call *get-parent* pointer))
' 169 (funcall next)
' 170 (cerror "Ignore" "Finalizer for object with a parent called."))
' 171 (error (condition)
' 172 (smoke::report-finalize-error condition "qt:object"
' 173 (name class) pointer)))))))
' 174
' 175
' 176 ;;;
' 177 ;;; The event-notify callback get called by QCoreApplication, on
' 178 ;;; notification of an event.
' 179 ;;;
' 180 ;;; The DATA argument is an array of size three, containing the
' 181 ;;; pointers:
' 182 ;;;
' 183 ;;; void* receiver
' 184 ;;; void* event
' 185 ;;; void* result
' 186 ;;; in that order.
' 187 ;;;
' 188 ;;; Returning true marks the event as handled; false on the other hand
' 189 ;;; leaves the event processing unchanged.
' 190 ;;;
' 191 ;;; See: QCoreApplication::notifyInternal(QObject *receiver, QEvent
' 192 ;;; *event)
' 193
' 194 (cffi:defcallback event-notify smoke:cxx-bool
' 195 ((data :pointer))
' 196 (declare (optimize (speed 3)))
' 197 (let ((receiver (smoke::get-object (cffi:mem-aref data :pointer 0)))
2009-08-02 tobias 198 (event (make-instance 'qt:event
11:29:02 ' 199 :pointer (cffi:mem-aref data :pointer 1))))
2010-01-10 tobias 200 (enum-case (cxx:type event)
08:52:49 ' 201 (qt:event.+child-added+
2009-08-02 tobias 202 (let ((child-event (make-instance 'qt:child-event
11:29:02 ' 203 :pointer
' 204 (smoke::upcast event (find-class 'qt:child-event)))))
' 205 (tg:cancel-finalization (cxx:child child-event))
' 206 (when (smoke::has-pointer-p (smoke::pointer (cxx:child child-event)))
' 207 (unless receiver
2009-08-02 tobias 208 (setf receiver (ensure-smoke-parent (cxx:child child-event))))
2009-08-02 tobias 209 (smoke::transfer-ownership-to (cxx:child child-event) receiver))))
2010-01-10 tobias 210 (qt:event.+child-removed+
2009-08-02 tobias 211 (let* ((child-event (make-instance 'qt:child-event
11:29:02 ' 212 :pointer (smoke::upcast event
' 213 (find-class 'qt:child-event)))))
' 214 ;; We receive child removed events for any QObject, whether
' 215 ;; it was constructed by Smoke or not. Only take ownership of
' 216 ;; objects that have been constructed by Smoke.
' 217 (when (smoke::has-pointer-p (smoke::pointer (cxx:child child-event)))
' 218 (assert receiver)
' 219 (smoke::take-ownership (cxx:child child-event) receiver))))))
2010-01-10 tobias 220 nil)
08:52:49 ' 221
' 222 (eval-when (:compile-toplevel :load-toplevel :execute)
' 223 (cffi:defcfun qt-smoke-register-event-notify :boolean
' 224 (event-notify :pointer)))
' 225
' 226 (defun register-event-notify ()
' 227 (let ((ret (qt-smoke-register-event-notify (cffi:callback event-notify))))
' 228 (unless ret
2009-08-02 tobias 229 (error "Registering event-notify callback failed."))))
11:15:21 ' 230
' 231 (defun check-child-parent-ownership ()
' 232 (loop for parent being the hash-values of smoke::*object-map* do
' 233 (loop for child in (smoke::owned-objects parent) do
' 234 (when (typep child 'qt:object)
' 235 (assert (eql (cxx:parent child) parent)
' 236 (child parent)
' 237 "cl-smoke thinks ~A has the parent ~A, but ~A is its parent."
' 238 child parent (cxx:parent child))))))
2010-01-10 tobias 239
2009-08-02 tobias 240 (eval-startup ()
2010-01-10 tobias 241 (register-event-notify))
Crece desde el pueblo el futuro / crece desde el pie