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