repos / qt.gui / annotate_shade
summary | shortlog | log | tree | commit | commitdiff | headdiff | annotate | filehistory
normal | plain | shade | zebra
Transfer ownerhip only for smoke classes.
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))
' 7 (defmethod cxx:static-meta-object ((class cxx:class))
' 8 (cxx:static-meta-object (smoke::find-smoke-class class))))
2010-01-10 tobias 9
2009-06-11 tobias 10 (defmethod documentation :around ((class cxx:class)
14:59:48 ' 11 (doc-type t))
' 12 (if (and (subtypep class (find-class 'object))
2010-01-10 tobias 13 (not (subtypep class (find-class 'cxx:class))))
08:52:49 ' 14 (format nil "~@[~A~%~]Properties:~%~T~{~<~%~T~0,75:; ~(~A~)~>~}
' 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-06-11 tobias 67 ; (typep (class-of object) 'cxx:class)
14:59:48 ' 68 (not (null-pointer-p (smoke::pointer (cxx:parent object)))))
2009-06-10 tobias 69 (smoke::transfer-ownership-to object (cxx:parent 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-08-02 tobias 76 (format stream "The object ~A ~A of type cxx:class
11:15:21 ' 77 has a parent but got garbage collected."
' 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")))
' 94 (defun print-object-to-string (object)
' 95 (with-output-to-string (stream)
' 96 (print-object object stream)))
2010-01-10 tobias 97
2009-06-11 tobias 98 (defmethod smoke::make-finalize ((object object))
2009-06-21 tobias 99 "Delete the qt:object OBJECT,
2010-01-10 tobias 100 by calling cxx:delete-later iff it has no parent."
2009-06-21 tobias 101 (let ((pointer (pointer object))
09:29:25 ' 102 (class (class-of object))
' 103 (next (call-next-method)))
' 104 (if (typep (class-of object) 'cxx:class)
' 105 #'(lambda ()
' 106 (handler-case
' 107 (if (null-pointer-p (smoke::pointer-call *get-parent* pointer))
' 108 (smoke::pointer-call *delete-later* pointer)
2009-06-10 tobias 109 (error (make-condition 'wrapper-gc
12:14:34 ' 110 :class-name (name class)
2009-06-21 tobias 111 :pointer pointer)))
09:29:25 ' 112 (error (condition)
' 113 (smoke::report-finalize-error condition "qt:object wrap"
' 114 (name class) pointer))))
' 115 #'(lambda ()
' 116 (handler-case
' 117 (if (null-pointer-p (smoke::pointer-call *get-parent* pointer))
2010-01-10 tobias 118 (funcall next)
2009-06-10 tobias 119 (cerror "Ignore" "Finalizer for object with a parent called."))
2009-06-21 tobias 120 (error (condition)
09:29:25 ' 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-06-10 tobias 142 (let ((receiver (smoke::get-object (cffi:mem-aref data :pointer 0)))
12:14:34 ' 143 (event (make-instance 'event :pointer (cffi:mem-aref data :pointer 1))))
2010-01-10 tobias 144 (enum-case (cxx:type event)
2009-06-11 tobias 145 (event.+child-added+
2009-06-10 tobias 146 (let ((child-event (make-instance 'child-event
2009-08-02 tobias 147 :pointer
2009-06-11 tobias 148 (smoke::upcast event (find-class 'child-event)))))
2009-06-10 tobias 149 (when (smoke::has-pointer-p (smoke::pointer (cxx:child child-event)))
12:14:34 ' 150 (assert receiver)
' 151 (smoke::transfer-ownership-to (cxx:child child-event) receiver))))
2009-06-11 tobias 152 (event.+child-removed+
14:59:48 ' 153 (let* ((child-event (make-instance 'child-event
2009-08-02 tobias 154 :pointer (smoke::upcast event
2009-06-11 tobias 155 (find-class 'child-event)))))
2009-07-01 tobias 156 ;; We receive child removed events for any QObject, wherter
10:58:06 ' 157 ;; it was construted by Smoke or not. Only take ownership of objects
2009-07-22 tobias 158 ;; that have been constructed by Smoke.
2009-08-02 tobias 159 (when (smoke::has-pointer-p (smoke::pointer (cxx:child child-event)))
2009-06-10 tobias 160 (assert receiver)
12:14:34 ' 161 (smoke::take-ownership (cxx:child child-event) receiver))))))
2010-01-10 tobias 162 nil)
08:52:49 ' 163
' 164 (eval-when (:compile-toplevel :load-toplevel :execute)
' 165 (cffi:defcfun qt-smoke-register-event-notify :boolean
' 166 (event-notify :pointer)))
' 167
' 168 (defun register-event-notify ()
' 169 (let ((ret (qt-smoke-register-event-notify (cffi:callback event-notify))))
' 170 (unless ret
2009-06-21 tobias 171 (error "The event-notify callback table is full."))))
2010-01-10 tobias 172
2009-08-02 tobias 173 (smoke:eval-startup ()
2010-01-10 tobias 174 (register-event-notify))
Crece desde el pueblo el futuro / crece desde el pie