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