repos
/
qt.gui
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
filehistory
normal
|
plain
|
shade
|
zebra
Update to the new smokegenerator.
Annotate for file src/object.lisp
2010-01-10 tobias
1
(in-package :cl-smoke.qt-impl)
08:52:49 '
2
'
3
;; Smoke always calls the method of the class the object is assumed to
'
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
(defmethod cxx:static-meta-object ((class cxx:class))
'
15
(cxx:static-meta-object (smoke::find-smoke-class class)))
'
16
'
17
(defmethod documentation :around ((class smoke::smoke-standard-class)
'
18
(doc-type (eql 't)))
'
19
(if (and (subtypep class (find-class 'qt:object))
'
20
(not (subtypep class (find-class 'cxx:class))))
'
21
(format nil "~@[~A~%~]Properties:~%~T~{~<~%~T~0,75:; ~(~A~)~>~}
'
22
'
23
Signals:
'
24
~{~T~A~%~}
'
25
Slots:
'
26
~{~T~A~%~}"
'
27
(call-next-method) (sort (qt:class-direct-properties class) #'string<=)
'
28
(sort (class-signals class) #'string<=)
'
29
(sort (class-slots class) #'string<=))
'
30
(call-next-method)))
'
31
'
32
(defmethod print-object ((object qt:object) stream)
'
33
(if (or (not (slot-boundp object 'pointer))
'
34
(null-pointer-p (pointer object)))
'
35
(call-next-method)
'
36
(if (string= "" (cxx:object-name object))
'
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))
2010-01-10 tobias
43
(princ (cxx:object-name object) stream)))))
08:52:49 '
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))))
'
51
'
52
(defun meta-object-methods (meta-object &optional (direct-only nil))
'
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
'
58
(defun meta-object-signals (meta-object &key all)
'
59
(mapcar #'cxx:signature
'
60
(remove-if-not #'(lambda (m) (enum= qt:meta-method.+signal+
'
61
(cxx:method-type m)))
'
62
(meta-object-methods meta-object (not all)))))
'
63
'
64
(defun class-signals (class &key all)
'
65
(meta-object-signals (cxx:static-meta-object class) :all all))
'
66
'
67
(defun meta-object-slots (meta-object &key all)
'
68
(mapcar #'cxx:signature
'
69
(remove-if-not #'(lambda (m) (enum= qt:meta-method.+slot+
'
70
(cxx:method-type m)))
'
71
(meta-object-methods meta-object (not all)))))
'
72
'
73
'
74
(defun class-slots (class &key all)
'
75
(meta-object-slots (cxx:static-meta-object class) :all all))
'
76
'
77
(defun parent-p (object)
'
78
(not (null-pointer-p (smoke::pointer-call
'
79
(smoke::make-smoke-method-from-name
'
80
(find-class 'qt:object)
'
81
"parent")
'
82
(smoke::pointer object)))))
'
83
'
84
'
85
;; FIXME this might not be that smart.
2009-08-27 tobias
86
(eval-startup (:compile-toplevel :execute)
2010-01-10 tobias
87
(defparameter *destroyed-slot* (qt:make-slot
08:52:49 '
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
2010-01-10 tobias
95
(defun ensure-smoke-parent (object)
08:52:49 '
96
(declare (optimize (speed 3)))
'
97
(let ((parent (cxx:parent object)))
'
98
(assert (not (null-pointer-p (smoke:pointer parent)))
'
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))))
2010-01-10 tobias
122
parent))
08:52:49 '
123
'
124
(defmethod initialize-instance :after ((object qt:object)
'
125
&key (pointer nil pointer-p) &allow-other-keys)
'
126
"Registers the object to the parent when a parent was set in the constructor
'
127
and the objects metaclass is SMOKE-WRAPPER-CLASS."
'
128
(declare (optimize (speed 3)))
'
129
(when (and (not pointer-p)
'
130
(null-pointer-p (smoke::pointer object)))
'
131
(error "Object ~A has not been constructed" object))
'
132
(when (and (null pointer)
'
133
(not (null-pointer-p (smoke::pointer object)))
'
134
(parent-p object))
'
135
(smoke::transfer-ownership-to object
'
136
(ensure-smoke-parent object))))
'
137
'
138
(define-condition wrapper-gc (storage-condition)
'
139
((object-class :initarg :object-class
'
140
:documentation "The class of the gc'ed object.")
'
141
(pointer :initarg :pointer))
'
142
(:report (lambda (condition stream)
'
143
(format stream "The object ~A ~A of type cxx:class
'
144
has the parent but got garbage collected."
'
145
(slot-value condition 'object-class)
'
146
(slot-value condition 'pointer)))))
'
147
'
148
(eval-startup (:compile-toplevel :execute)
'
149
(defparameter *get-parent*
'
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")))
'
156
'
157
(defmethod smoke::make-finalize ((object qt:object))
'
158
"Delete the qt:object OBJECT,
'
159
by calling cxx:delete-later iff it has no parent."
'
160
(let ((pointer (pointer object))
'
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
'
171
:object-class class
'
172
:pointer pointer)))
'
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))
'
180
(funcall next)
'
181
(cerror "Ignore" "Finalizer for object with a parent called."))
'
182
(error (condition)
'
183
(smoke::report-finalize-error condition "qt:object"
'
184
(name class) pointer)))))))
'
185
'
186
'
187
;;;
'
188
;;; The event-notify callback get called by QCoreApplication, on
'
189
;;; notification of an event.
'
190
;;;
'
191
;;; The DATA argument is an array of size three, containing the
'
192
;;; pointers:
'
193
;;;
'
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
;;;
'
202
;;; See: QCoreApplication::notifyInternal(QObject *receiver, QEvent
'
203
;;; *event)
'
204
'
205
(cffi:defcallback event-notify smoke:cxx-bool
'
206
((data :pointer))
'
207
(declare (optimize (speed 3)))
'
208
(let ((receiver (smoke::get-object (cffi:mem-aref data :pointer 0)))
'
209
(event (cast-event
'
210
(make-instance 'qt:event
'
211
:pointer (cffi:mem-aref data :pointer 1)))))
'
212
(enum-case (cxx:type event)
'
213
(qt:event.+child-added+
'
214
(tg:cancel-finalization (cxx:child event))
'
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)))
'
219
(qt:event.+child-removed+
'
220
;; We receive child removed events for any QObject, whether
'
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)))))
'
226
nil)
'
227
'
228
(eval-when (:compile-toplevel :load-toplevel :execute)
'
229
(cffi:defcfun qt-smoke-register-event-notify :boolean
'
230
(event-notify :pointer)))
'
231
'
232
(defun register-event-notify ()
'
233
(let ((ret (qt-smoke-register-event-notify (cffi:callback event-notify))))
'
234
(unless ret
'
235
(error "Registering event-notify callback failed."))))
'
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))))))
'
245
'
246
(eval-startup ()
'
247
(register-event-notify))