repos
/
qt.gui
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
filehistory
normal
|
plain
|
shade
|
zebra
move emit slot code to new function ACTIVATE & image startup fix for STATIC-META-OBJECT
Annotate for file src/object.lisp
2010-01-10 tobias
1
(in-package :cl-smoke.qt-impl)
08:52:49 '
2
2009-07-02 tobias
3
(smoke:eval-startup (:load-toplevel :compile-toplevel :execute)
19:12:45 '
4
(let ((object (make-instance 'qt:object)))
'
5
(defmethod cxx:static-meta-object ((class (eql (find-class 'qt:object))))
'
6
"No OBJECT.STATIC-META-OBJECT (r558420)."
'
7
(cxx:meta-object object))))
'
8
'
9
(defmethod cxx:static-meta-object ((class cxx:class))
'
10
(cxx:static-meta-object (smoke::find-smoke-class class)))
2010-01-10 tobias
11
08:52:49 '
12
(defmethod documentation :around ((class smoke::smoke-standard-class)
'
13
(doc-type (eql 't)))
'
14
(if (and (subtypep class (find-class 'qt:object))
'
15
(not (subtypep class (find-class 'cxx:class))))
'
16
(format nil "~@[~A~%~]Properties:~%~T~{~<~%~T~0,75:; ~(~A~)~>~}
'
17
'
18
Signals:
'
19
~{~T~A~%~}
'
20
Slots:
'
21
~{~T~A~%~}"
'
22
(call-next-method) (sort (qt:class-direct-properties class) #'string<=)
'
23
(sort (class-signals class) #'string<=)
'
24
(sort (class-slots class) #'string<=))
'
25
(call-next-method)))
'
26
'
27
(defmethod print-object ((object qt:object) stream)
'
28
(if (or (not (slot-boundp object 'pointer))
'
29
(null-pointer-p (pointer object)))
'
30
(call-next-method)
2009-08-02 tobias
31
(print-unreadable-object (object stream :type t :identity t)
11:29:13 '
32
(princ (cxx:object-name object) stream))))
2010-01-10 tobias
33
08:52:49 '
34
(defun meta-object-methods (meta-object &optional (direct-only nil))
'
35
(loop for index from (if direct-only (cxx:method-offset meta-object) 0)
'
36
below (cxx:method-count meta-object)
'
37
collect (cxx:method meta-object index)))
'
38
'
39
'
40
(defun meta-object-signals (meta-object &key all)
'
41
(mapcar #'cxx:signature
'
42
(remove-if-not #'(lambda (m) (enum= qt:meta-method.+signal+
'
43
(cxx:method-type m)))
'
44
(meta-object-methods meta-object (not all)))))
'
45
'
46
(defun class-signals (class &key all)
'
47
(meta-object-signals (cxx:static-meta-object class) :all all))
'
48
'
49
(defun meta-object-slots (meta-object &key all)
'
50
(mapcar #'cxx:signature
'
51
(remove-if-not #'(lambda (m) (enum= qt:meta-method.+slot+
'
52
(cxx:method-type m)))
'
53
(meta-object-methods meta-object (not all)))))
'
54
'
55
'
56
(defun class-slots (class &key all)
'
57
(meta-object-slots (cxx:static-meta-object class) :all all))
'
58
'
59
(defun parent-p (object)
2009-08-02 tobias
60
(not (null-pointer-p (smoke::pointer-call (smoke::make-smoke-method-from-name (find-class 'qt:object)
11:15:21 '
61
"parent")
'
62
(smoke::pointer object)))))
2010-01-10 tobias
63
2009-08-02 tobias
64
(defun find-smoke-parent (object)
11:15:21 '
65
"Returns the first parent of OBJECT or OBJECT that is a Smoke class.
'
66
(the destructed callback is called when the object is freed.)"
'
67
;; FIXME allow usage of non smoke objects by connecting to the
'
68
;; destroyed() signal.
2010-01-10 tobias
69
(declare (optimize (speed 3)))
08:52:49 '
70
(let ((parent (cxx:parent object)))
2009-08-02 tobias
71
(if (not (null-pointer-p (smoke::pointer parent)))
11:15:21 '
72
(if (smoke::has-pointer-p (smoke::pointer parent))
'
73
parent
'
74
(find-smoke-parent parent))
2009-07-08 tobias
75
(error "No smoke parent found."))))
2010-01-10 tobias
76
08:52:49 '
77
(defmethod initialize-instance :after ((object qt:object)
'
78
&key (pointer nil pointer-p) &allow-other-keys)
'
79
"Registers the object to the parent when a parent was set in the constructor
'
80
and the objects metaclass is SMOKE-WRAPPER-CLASS."
'
81
(declare (optimize (speed 3)))
'
82
(when (and (not pointer-p)
'
83
(null-pointer-p (smoke::pointer object)))
'
84
(error "Object ~A has not been constructed" object))
'
85
(when (and (null pointer)
'
86
(not (null-pointer-p (smoke::pointer object)))
'
87
(parent-p object))
'
88
(smoke::transfer-ownership-to object
2009-08-02 tobias
89
(find-smoke-parent object))))
2010-01-10 tobias
90
08:52:49 '
91
(define-condition wrapper-gc (storage-condition)
2009-08-02 tobias
92
((class-name :initarg :class-name
11:15:21 '
93
:documentation "The class name of the gc'ed object.")
2010-01-10 tobias
94
(pointer :initarg :pointer))
08:52:49 '
95
(:report (lambda (condition stream)
2009-08-02 tobias
96
(format stream "The object ~A ~A of type cxx:class
11:15:21 '
97
has a parent but got garbage collected."
'
98
(slot-value condition 'class-name)
'
99
(slot-value condition 'pointer)))))
2010-01-10 tobias
100
2009-08-02 tobias
101
(smoke:eval-startup (:compile-toplevel :execute)
2009-07-22 tobias
102
(defparameter *get-parent*
22:21:01 '
103
(smoke::make-smoke-method-from-name (find-class 'qt:object) "parent"))
'
104
;; FIXME this leaks memory when QCoreApplication::exec is never called,
'
105
;; beause then, deleteLater has no effect.
'
106
(defparameter *delete-later*
'
107
(smoke::make-smoke-method-from-name (find-class 'qt:object) "deleteLater")))
2010-01-10 tobias
108
08:52:49 '
109
(defmethod smoke::make-finalize ((object qt:object))
'
110
"Delete the qt:object OBJECT,
'
111
by calling cxx:delete-later iff it has no parent."
'
112
(let ((pointer (pointer object))
'
113
(class (class-of object))
'
114
(next (call-next-method)))
'
115
(declare (function next))
'
116
(if (typep (class-of object) 'cxx:class)
'
117
#'(lambda ()
'
118
(declare (optimize (speed 3)))
'
119
(handler-case
'
120
(if (null-pointer-p (smoke::pointer-call *get-parent* pointer))
'
121
(smoke::pointer-call *delete-later* pointer)
'
122
(error (make-condition 'wrapper-gc
2009-08-02 tobias
123
:class-name (name class)
2010-01-10 tobias
124
:pointer pointer)))
08:52:49 '
125
(error (condition)
'
126
(smoke::report-finalize-error condition "qt:object wrap"
'
127
(name class) pointer))))
'
128
#'(lambda ()
'
129
(declare (optimize (speed 3)))
'
130
(handler-case
'
131
(if (null-pointer-p (smoke::pointer-call *get-parent* pointer))
'
132
(funcall next)
'
133
(cerror "Ignore" "Finalizer for object with a parent called."))
'
134
(error (condition)
'
135
(smoke::report-finalize-error condition "qt:object"
'
136
(name class) pointer)))))))
'
137
'
138
'
139
;;;
2009-07-22 tobias
140
;;; The event-notify callback get called by QCoreApplication,
22:21:01 '
141
;;; on notification of an event.
2010-01-10 tobias
142
;;;
2009-07-22 tobias
143
;;; The DATA argument is an array of size three, containing the pointers:
2010-01-10 tobias
144
;;; void* receiver
08:52:49 '
145
;;; void* event
'
146
;;; void* result
'
147
;;; in that order.
'
148
;;;
'
149
;;; Returning true marks the event as handled; false on the other hand
'
150
;;; leaves the event processing unchanged.
'
151
;;;
2009-07-22 tobias
152
;;; See: QCoreApplication::notifyInternal(QObject *receiver, QEvent *event)
2010-01-10 tobias
153
08:52:49 '
154
(cffi:defcallback event-notify smoke:cxx-bool
'
155
((data :pointer))
'
156
(declare (optimize (speed 3)))
'
157
(let ((receiver (smoke::get-object (cffi:mem-aref data :pointer 0)))
2009-08-02 tobias
158
(event (make-instance 'qt:event
11:29:02 '
159
:pointer (cffi:mem-aref data :pointer 1))))
2010-01-10 tobias
160
(enum-case (cxx:type event)
08:52:49 '
161
(qt:event.+child-added+
2009-08-02 tobias
162
(let ((child-event (make-instance 'qt:child-event
11:29:02 '
163
:pointer
'
164
(smoke::upcast event (find-class 'qt:child-event)))))
'
165
(tg:cancel-finalization (cxx:child child-event))
'
166
(when (smoke::has-pointer-p (smoke::pointer (cxx:child child-event)))
'
167
(unless receiver
2009-08-02 tobias
168
(setf receiver (find-smoke-parent (cxx:child child-event))))
2009-08-02 tobias
169
(smoke::transfer-ownership-to (cxx:child child-event) receiver))))
2010-01-10 tobias
170
(qt:event.+child-removed+
2009-08-02 tobias
171
(let* ((child-event (make-instance 'qt:child-event
11:29:02 '
172
:pointer (smoke::upcast event
'
173
(find-class 'qt:child-event)))))
'
174
;; We receive child removed events for any QObject, whether
2009-07-22 tobias
175
;; it was constructed by Smoke or not. Only take ownership of objects
22:21:01 '
176
;; that have been constructed by Smoke.
2009-08-02 tobias
177
(when (smoke::has-pointer-p (smoke::pointer (cxx:child child-event)))
11:29:02 '
178
(assert receiver)
'
179
(smoke::take-ownership (cxx:child child-event) receiver))))))
2010-01-10 tobias
180
nil)
08:52:49 '
181
'
182
(eval-when (:compile-toplevel :load-toplevel :execute)
'
183
(cffi:defcfun qt-smoke-register-event-notify :boolean
'
184
(event-notify :pointer)))
'
185
'
186
(defun register-event-notify ()
'
187
(let ((ret (qt-smoke-register-event-notify (cffi:callback event-notify))))
'
188
(unless ret
2009-08-02 tobias
189
(error "The Qt event-notify callback table is full."))))
2010-01-10 tobias
190
2009-08-02 tobias
191
(smoke:eval-startup ()
2010-01-10 tobias
192
(register-event-notify))