repos
/
qt.gui
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
filehistory
normal
|
plain
|
shade
|
zebra
Fix double space when printing a qt:object.
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
2009-08-27 tobias
14
(eval-startup (:load-toplevel :compile-toplevel :execute)
08:37:36 '
15
(let ((object (make-instance 'qt:object)))
'
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
(if (string= "" (cxx:object-name object))
11:29:13 '
43
(print-unreadable-object (object stream :type t :identity t))
'
44
(print-unreadable-object (object stream :type t :identity t)
'
45
(princ (cxx:object-name object) stream)))))
'
46
'
47
(defmethod print-object ((object qt:meta-object) stream)
'
48
(if (or (not (slot-boundp object 'pointer))
'
49
(null-pointer-p (pointer object)))
'
50
(call-next-method)
'
51
(print-unreadable-object (object stream :type t :identity t)
'
52
(princ (cxx:class-name object) stream))))
2010-01-10 tobias
53
08:52:49 '
54
(defun meta-object-methods (meta-object &optional (direct-only nil))
'
55
(loop for index from (if direct-only (cxx:method-offset meta-object) 0)
'
56
below (cxx:method-count meta-object)
'
57
collect (cxx:method meta-object index)))
'
58
'
59
'
60
(defun meta-object-signals (meta-object &key all)
'
61
(mapcar #'cxx:signature
'
62
(remove-if-not #'(lambda (m) (enum= qt:meta-method.+signal+
'
63
(cxx:method-type m)))
'
64
(meta-object-methods meta-object (not all)))))
'
65
'
66
(defun class-signals (class &key all)
'
67
(meta-object-signals (cxx:static-meta-object class) :all all))
'
68
'
69
(defun meta-object-slots (meta-object &key all)
'
70
(mapcar #'cxx:signature
'
71
(remove-if-not #'(lambda (m) (enum= qt:meta-method.+slot+
'
72
(cxx:method-type m)))
'
73
(meta-object-methods meta-object (not all)))))
'
74
'
75
'
76
(defun class-slots (class &key all)
'
77
(meta-object-slots (cxx:static-meta-object class) :all all))
'
78
'
79
(defun parent-p (object)
'
80
(not (null-pointer-p (smoke::pointer-call
'
81
(smoke::make-smoke-method-from-name
'
82
(find-class 'qt:object)
'
83
"parent")
'
84
(smoke::pointer object)))))
'
85
'
86
'
87
;; FIXME this might not be that smart.
2009-08-27 tobias
88
(eval-startup ()
2010-01-10 tobias
89
(defparameter *destroyed-slot* (qt:make-slot
08:52:49 '
90
#'(lambda (object)
'
91
(foreign-funcall-pointer
'
92
(get-callback 'smoke::destructed)
'
93
() :pointer (smoke:pointer object))))))
'
94
'
95
(defun ensure-smoke-parent (object)
'
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
(smoke::transfer-ownership-to parent (ensure-smoke-parent parent)))
2010-01-10 tobias
120
parent))
08:52:49 '
121
'
122
(defmethod initialize-instance :after ((object qt:object)
'
123
&key (pointer nil pointer-p) &allow-other-keys)
'
124
"Registers the object to the parent when a parent was set in the constructor
'
125
and the objects metaclass is SMOKE-WRAPPER-CLASS."
'
126
(declare (optimize (speed 3)))
'
127
(when (and (not pointer-p)
'
128
(null-pointer-p (smoke::pointer object)))
'
129
(error "Object ~A has not been constructed" object))
'
130
(when (and (null pointer)
'
131
(not (null-pointer-p (smoke::pointer object)))
'
132
(parent-p object))
'
133
(smoke::transfer-ownership-to object
'
134
(ensure-smoke-parent object))))
'
135
'
136
(define-condition wrapper-gc (storage-condition)
'
137
((object-class :initarg :object-class
'
138
:documentation "The class of the gc'ed object.")
'
139
(pointer :initarg :pointer))
'
140
(:report (lambda (condition stream)
'
141
(format stream "The object ~A ~A of type cxx:class
'
142
has the parent but got garbage collected."
'
143
(slot-value condition 'object-class)
'
144
(slot-value condition 'pointer)))))
'
145
'
146
(eval-startup (:compile-toplevel :execute)
'
147
(defparameter *get-parent*
'
148
(smoke::make-smoke-method-from-name (find-class 'qt:object) "parent"))
'
149
'
150
;; FIXME this leaks memory when QCoreApplication::exec() is never
'
151
;; called, beause then, deleteLater() has no effect.
'
152
(defparameter *delete-later*
'
153
(smoke::make-smoke-method-from-name (find-class 'qt:object) "deleteLater")))
'
154
'
155
(defmethod smoke::make-finalize ((object qt:object))
'
156
"Delete the qt:object OBJECT,
'
157
by calling cxx:delete-later iff it has no parent."
'
158
(let ((pointer (pointer object))
'
159
(class (class-of object))
'
160
(next (call-next-method)))
'
161
(declare (function next))
'
162
(if (typep (class-of object) 'cxx:class)
'
163
#'(lambda ()
'
164
(declare (optimize (speed 3)))
'
165
(handler-case
'
166
(if (null-pointer-p (smoke::pointer-call *get-parent* pointer))
'
167
(smoke::pointer-call *delete-later* pointer)
'
168
(error (make-condition 'wrapper-gc
'
169
:object-class class
'
170
:pointer pointer)))
'
171
(error (condition)
'
172
(smoke::report-finalize-error condition "qt:object wrap"
'
173
(name class) pointer))))
'
174
#'(lambda ()
'
175
(declare (optimize (speed 3)))
'
176
(handler-case
'
177
(if (null-pointer-p (smoke::pointer-call *get-parent* pointer))
'
178
(funcall next)
'
179
(cerror "Ignore" "Finalizer for object with a parent called."))
'
180
(error (condition)
'
181
(smoke::report-finalize-error condition "qt:object"
'
182
(name class) pointer)))))))
'
183
'
184
'
185
;;;
'
186
;;; The event-notify callback get called by QCoreApplication, on
'
187
;;; notification of an event.
'
188
;;;
'
189
;;; The DATA argument is an array of size three, containing the
'
190
;;; pointers:
'
191
;;;
'
192
;;; void* receiver
'
193
;;; void* event
'
194
;;; void* result
'
195
;;; in that order.
'
196
;;;
'
197
;;; Returning true marks the event as handled; false on the other hand
'
198
;;; leaves the event processing unchanged.
'
199
;;;
'
200
;;; See: QCoreApplication::notifyInternal(QObject *receiver, QEvent
'
201
;;; *event)
'
202
'
203
(cffi:defcallback event-notify smoke:cxx-bool
'
204
((data :pointer))
'
205
(declare (optimize (speed 3)))
'
206
(let ((receiver (smoke::get-object (cffi:mem-aref data :pointer 0)))
'
207
(event (cast-event
'
208
(make-instance 'qt:event
'
209
:pointer (cffi:mem-aref data :pointer 1)))))
'
210
(enum-case (cxx:type event)
'
211
(qt:event.+child-added+
'
212
(tg:cancel-finalization (cxx:child event))
'
213
(when (smoke::has-pointer-p (smoke::pointer (cxx:child event)))
'
214
(unless receiver
'
215
(setf receiver (ensure-smoke-parent (cxx:child event))))
'
216
(smoke::transfer-ownership-to (cxx:child event) receiver)))
'
217
(qt:event.+child-removed+
'
218
;; We receive child removed events for any QObject, whether
'
219
;; it was constructed by Smoke or not. Only take ownership of
'
220
;; objects that have been constructed by Smoke.
'
221
(when (smoke::has-pointer-p (smoke::pointer (cxx:child event)))
'
222
(assert receiver)
'
223
(smoke::take-ownership (cxx:child event) receiver)))))
'
224
nil)
'
225
'
226
(eval-when (:compile-toplevel :load-toplevel :execute)
'
227
(cffi:defcfun qt-smoke-register-event-notify :boolean
'
228
(event-notify :pointer)))
'
229
'
230
(defun register-event-notify ()
'
231
(let ((ret (qt-smoke-register-event-notify (cffi:callback event-notify))))
'
232
(unless ret
'
233
(error "Registering event-notify callback failed."))))
'
234
'
235
(defun check-child-parent-ownership ()
'
236
(loop for parent being the hash-values of smoke::*object-map* do
'
237
(loop for child in (smoke::owned-objects parent) do
'
238
(when (typep child 'qt:object)
'
239
(assert (eql (cxx:parent child) parent)
'
240
(child parent)
'
241
"cl-smoke thinks ~A has the parent ~A, but ~A is its parent."
'
242
child parent (cxx:parent child))))))
'
243
'
244
(eval-startup ()
'
245
(register-event-notify))