darcs - qt.core

1 (in-package :cl-smoke.qt.core)

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 cl-smoke-meta-object :pointer (object :pointer))

10 (defun meta-object (object)

11 (make-instance 'qt:meta-object

12 :pointer (cl-smoke-meta-object (pointer object))))

14 (defmethod cxx:static-meta-object ((class cxx:class))

15 (cxx:static-meta-object (smoke::find-smoke-class class)))

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~)~>~}

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)))

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)

38 (when (smoke::const-p object)

39 (princ "CONST " stream)))

40 (print-unreadable-object (object stream :type t :identity t)

41 (when (smoke::const-p object)

42 (princ "CONST " stream))

43 (princ (cxx:object-name object) stream)))))

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))))

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)))

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)))))

64 (defun class-signals (class &key all)

65 (meta-object-signals (cxx:static-meta-object class) :all all))

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)))))

74 (defun class-slots (class &key all)

75 (meta-object-slots (cxx:static-meta-object class) :all all))

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)))))

85 ;; FIXME this might not be that smart.

86 (eval-startup (:compile-toplevel :execute)

87 (defparameter *destroyed-slot* (qt:make-slot

88 #'(lambda (object)

89 (foreign-funcall-pointer

90 (get-callback 'smoke::destructed)

91 () :pointer (smoke:pointer object))))))

93 (defvar *toplevel-objects* nil)

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)

119 (if (null-pointer-p (smoke:pointer (cxx:parent parent)))

120 (push parent *toplevel-objects*)

121 (smoke::transfer-ownership-to parent (ensure-smoke-parent parent))))

122 parent))

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 cl-smoke-register-event-notify :boolean

230 (event-notify :pointer)))

231

232 (defun register-event-notify ()

233 (let ((ret (cl-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))