Sun Aug 2 13:15:21 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Support ownership transfer to non smoke wrapped QObjects & cleanup C++ to Lisp translation.
hunk ./qt.mbd 48
- ("object" (:needs "qt"))
+ ("object" (:needs "qt" "signal-slot" "qstring"))
hunk ./src/application.lisp 43
- (cerror "Delete the active application." "Active application not created by QT:WITH-APP.")
+ (cerror (format nil "Delete the active application ~A."
+ (qt:core-application.instance))
+ "Active application not created by QT:WITH-APP.")
hunk ./src/lib/qt-smoke.cpp 17
- * @return @c true on success and @c false when the callback table is full.
+ * @return @c true on success and @c false otherwise
hunk ./src/lib/qt-smoke.cpp 28
+/** Returns the most specific QMetaObject of the QObject instance @a object.
+ * Used to determine the actual class of an object. Smoke can not be used since it calls the
+ * metaObject() of the class the method was called for.
+ *
+ * @param object A QObject
+ *
+ * @return QMetaObject
+ */
+CL_SMOKE_QT_EXPORT void*
+qt_smoke_meta_object(void* object)
+{
+ Q_ASSERT(object);
+ static_cast<QObject*>(object)->metaObject();[_^I_][_$_]
+}
+
+
hunk ./src/list.lisp 24
- (define-foreign-type ,list-type ()
- ()
- (:actual-type :pointer))
- (define-parse-method ,list-type ()
- (make-instance ',list-type))
- (eval-when (:load-toplevel :execute)
- ,@(loop for type-name in (ensure-list type-name) collect [_$_]
- `(smoke::add-type ,(format nil "const QList<~A>&" type-name)
- ',list-type))
- ,@(loop for type-name in (ensure-list type-name) collect [_$_]
- `(smoke::add-type ,(format nil "QList<~A>" type-name) ',list-type)))
+ ;; To Lisp
hunk ./src/list.lisp 26
- `(defmethod translate-from-foreign (list (type ,list-type))
+ `(defun ,(symbolicate 'from- type-name) (list-pointer)
hunk ./src/list.lisp 29
- list))))
+ list-pointer))))
hunk ./src/list.lisp 37
- list index)
- (smoke::make-smoke-type *smoke-module* ,type-name)))))))
- (defmethod free-translated-object (pointer (type ,list-type) param)
- (declare (ignore param))
- (,(symbolicate 'qt-smoke-free-list- type)
- pointer))
+ list-pointer index)
+ (smoke::make-smoke-type *smoke-module*
+ ,type-name)))))))
+ ,@(loop for type-name in (ensure-list type-name) collect
+ `(define-to-lisp-translation
+ (,(format nil "const QList<~A>&" type-name)
+ ,(format nil "QList<~A>" type-name))
+ ,(symbolicate 'from- type-name)
+ ,(symbolicate 'qt-smoke-free-list- type)))
+ ;; From Lisp
hunk ./src/list.lisp 52
- (smoke::make-cleanup-pointer
+ (make-cleanup-pointer
hunk ./src/list.lisp 57
- ,(format nil "QLIst<~A>" type-name))
+ ,(format nil "QList<~A>" type-name))
hunk ./src/msg-handler.lisp 9
+;; QtMsgHandler is a typedef for a pointer.
+(define-pointer-typedef "QtMsgHandler" foreign-pointer)
+
hunk ./src/object.lisp 3
-(smoke:eval-startup (:load-toplevel :compile-toplevel :execute)
+;; Smoke always calls the method of the class the object is assumed to
+;; be and not the most specific method like required for virtual
+;; methods. Thus we implement a virtual metaObject() method to
+;; determine the actual class. This is only needed for objects not
+;; constructed by Smoke, since otherwise we would know the most
+;; specific class.
+(defcfun qt-smoke-meta-object :pointer (object :pointer))
+(defun meta-object (object)
+ (make-instance 'qt:meta-object
+ :pointer (qt-smoke-meta-object (pointer object))))
+
+(eval-startup (:load-toplevel :compile-toplevel :execute)
hunk ./src/object.lisp 71
- (not (null-pointer-p (smoke::pointer-call (smoke::make-smoke-method-from-name (find-class 'qt:object)
- "parent")
- (smoke::pointer object)))))
+ (not (null-pointer-p (smoke::pointer-call
+ (smoke::make-smoke-method-from-name [_$_]
+ (find-class 'qt:object)
+ "parent")
+ (smoke::pointer object)))))
+
hunk ./src/object.lisp 78
-(defun find-smoke-parent (object)
- "Returns the first parent of OBJECT or OBJECT that is a Smoke class.
- (the destructed callback is called when the object is freed.)"
- ;; FIXME allow usage of non smoke objects by connecting to the
- ;; destroyed() signal.
+;; FIXME this might not be that smart.
+(eval-startup ()
+ (defparameter *destroyed-slot* (qt:make-slot
+ #'(lambda (object)
+ (foreign-funcall-pointer
+ (get-callback 'smoke::destructed)
+ () :pointer (smoke:pointer object))))))
+
+(defun ensure-smoke-parent (object)
hunk ./src/object.lisp 89
- (if (not (null-pointer-p (smoke::pointer parent)))
- (if (smoke::has-pointer-p (smoke::pointer parent))
- parent
- (find-smoke-parent parent))
- (error "No smoke parent found for ~A." object))))
+ (assert (not (null-pointer-p (smoke:pointer parent)))
+ ()
+ "The object ~A has not parent." object)
+ (unless (smoke::has-pointer-p (smoke:pointer parent))
+ ;; Before we ADD-OBJECT PARENT it must know its real class to
+ ;; prevent a clash when the same pointer is returned by a
+ ;; function with a more specific type.
+ (change-class parent [_$_]
+ ;; Note: there can be classes that are not known
+ ;; to Smoke, like KDE's OxygenStyle that might
+ ;; be seen by the event-notify callback. But
+ ;; it's probably save to assume the user will
+ ;; never use those.
+ (let ((class-name (cxx:class-name (meta-object parent))))
+ (smoke::lispify class-name (ecase (char class-name 0)
+ (#\Q :qt)
+ (#\K :kde)))))
+ (smoke::add-object parent)
+ (qt:connect (qt:get-signal parent "destroyed(QObject*)")
+ *destroyed-slot* qt:+direct-connection+)
+ (tg:cancel-finalization parent)
+ (smoke::transfer-ownership-to parent (ensure-smoke-parent parent)))
+ parent))
hunk ./src/object.lisp 125
- (find-smoke-parent object))))
+ (ensure-smoke-parent object))))
hunk ./src/object.lisp 128
- ((class-name :initarg :class-name
- :documentation "The class name of the gc'ed object.")
+ ((object-class :initarg :object-class
+ :documentation "The class of the gc'ed object.")
hunk ./src/object.lisp 132
- (format stream "The object ~A ~A of type cxx:class
-has a parent but got garbage collected."
- (slot-value condition 'class-name)
- (slot-value condition 'pointer)))))
+ (format stream "The object ~A ~A of type cxx:class
+has the parent but got garbage collected."
+ (slot-value condition 'object-class)
+ (slot-value condition 'pointer)))))
hunk ./src/object.lisp 137
-(smoke:eval-startup (:compile-toplevel :execute)
+(eval-startup (:compile-toplevel :execute)
hunk ./src/object.lisp 160
- :class-name (name class)
+ :object-class class
hunk ./src/object.lisp 208
- (setf receiver (find-smoke-parent (cxx:child child-event))))
+ (setf receiver (ensure-smoke-parent (cxx:child child-event))))
hunk ./src/object.lisp 229
- (error "The Qt event-notify callback table is full."))))
+ (error "Registering event-notify callback failed."))))
+
+(defun check-child-parent-ownership ()
+ (loop for parent being the hash-values of smoke::*object-map* do
+ (loop for child in (smoke::owned-objects parent) do
+ (when (typep child 'qt:object)
+ (assert (eql (cxx:parent child) parent)
+ (child parent)
+ "cl-smoke thinks ~A has the parent ~A, but ~A is its parent."
+ child parent (cxx:parent child))))))
hunk ./src/object.lisp 240
-(smoke:eval-startup ()
+(eval-startup ()
hunk ./src/qstring.lisp 13
-(define-foreign-type qstring ()
- ()
- (:actual-type :pointer))
-
-(defun setup-type-map ()
- (smoke::add-type "QString" 'qstring)
- (smoke::add-type "const QString&" 'qstring))
-
-(eval-when (:load-toplevel :execute)
- (setup-type-map))
-
hunk ./src/qstring.lisp 26
-(define-parse-method qstring ()
- (make-instance 'qstring))
-
hunk ./src/qstring.lisp 27
- (let ((method (smoke::make-smoke-method-from-name (find-class 'qt:byte-array)
- "data")))
- (defmethod cxx:data ((array qt:byte-array))
- (values ;; Discharge second return value (length of string)
- (foreign-string-to-lisp (smoke::pointer-call method
- (smoke::pointer array))
- :count (cxx:size array))))))
+ (let ((method (smoke::make-smoke-method-from-name (find-class 'qt:byte-array)
+ "data")))
+ (defmethod cxx:data ((array qt:byte-array))
+ (values ;; Discharge second return value (length of string)
+ (foreign-string-to-lisp (smoke::pointer-call method
+ (smoke::pointer array))
+ :count (cxx:size array))))))
hunk ./src/qstring.lisp 35
-(defmethod translate-from-foreign (string (type qstring))
+(defun from-qstring (qstring)
hunk ./src/qstring.lisp 37
- :pointer (qt-smoke-qstring-to-byte-array string))))
+ :pointer (qt-smoke-qstring-to-byte-array qstring))))
hunk ./src/qstring.lisp 39
-(defmethod free-translated-object (pointer (type qstring) param)
- (declare (ignore param))
- (qt-smoke-free-qstring pointer))
+(define-to-lisp-translation ("QString" "const QString&")
+ from-qstring qt-smoke-free-qstring)
hunk ./src/qstring.lisp 46
- #'(lambda (pointer)
- (free-translated-object pointer (make-instance 'qstring)
- nil))))
+ #'qt-smoke-free-qstring))
hunk ./src/signal-slot/connect.lisp 16
- (assert (subtypep signal-arg slot-arg))))
+ (if (typep signal-arg 'smoke::smoke-type)
+ (assert (smoke-type= signal-arg slot-arg))
+ (assert (subtypep signal-arg slot-arg)))))
hunk ./src/signal-slot/connect.lisp 44
- :args (list (signal-object sender))
+ :arg0 (signal-object sender)
hunk ./src/signal-slot/connect.lisp 47
+
hunk ./src/signal-slot/connect.lisp 69
+(defmethod print-object ((qt-signal qt-signal) stream)
+ (print-unreadable-object (qt-signal stream :type t :identity t)
+ (when (slot-boundp qt-signal 'sender)
+ (princ (qsender qt-signal) stream))
+ (princ " " stream)
+ (when (slot-boundp qt-signal 'name)
+ (princ (name qt-signal) stream))))
+
hunk ./src/signal-slot/connect.lisp 84
- (let ((slot (qt:make-slot #'(lambda (&rest args)
- (apply function (cxx:parent *this*)
- args)))))
- (cxx:set-parent slot receiver)
- slot)))
+ (make-instance 'qslot [_$_]
+ :arg0 receiver
+ :slot-function #'(lambda (&rest args)
+ (apply function (cxx:parent *this*)
+ args)))))
hunk ./src/signal-slot/connect.lisp 95
- (if (string= name normalized-name) ;; Avoid loop
+ (if (string= name normalized-name) ;; Avoid infinite recursion
hunk ./src/signal-slot/connect.lisp 109
- (if (string= name normalized-name) ;; Avoid loop
+ (if (string= name normalized-name) ;; Avoid infinite recursion
hunk ./src/signal-slot/connect.lisp 138
+ :arg0 (qsender qt-signal)
hunk ./src/signal-slot/connect.lisp 152
- (if (smoke::has-pointer-p (smoke:pointer (qsender qt-signal)))
- (setf (cxx:parent slot) (qsender qt-signal))
- ;; when QT-SIGNAL is not a Smoke instance.
- (progn
- (unless (qt:property-p (qsender qt-signal) 'connected-slots)
- (setf (qt:property (qsender qt-signal) 'connected-slots)
- (qt:make-lisp-variant (list))))
- (setf (qt:property (qsender qt-signal) 'connected-slots)
- (qt:make-lisp-variant
- (cons slot
- (qt:property (qsender qt-signal) 'connected-slots))))))
hunk ./src/signal-slot/slot.lisp 7
- :initform (error "no function specified")
+ :initform (error "no slot function specified")
hunk ./src/signal-slot/translate.lisp 55
- (0 (let ((cffi-type (smoke::get-type (name type))))
- (if (null cffi-type)
- (progn [_$_]
- pointer)
- (convert-from-foreign pointer
- cffi-type))))
+ (0 (if-let ((translation (gethash (name type) smoke::*to-lisp-translations*)))
+ ;; Do not free stack allocated stuff (e.g.: QString); that is the callers
+ ;; responisbility.
+ (funcall (car translation) pointer)
+ (error "Do not know how to convert the type ~A to Lisp." type)))
hunk ./src/string-list.lisp 20
-(define-foreign-type string-list ()
- ()
- (:actual-type :pointer))
-
-(eval-when (:load-toplevel)
- (smoke::add-type "QStringList" 'string-list)
- (smoke::add-type "const QStringList&" 'string-list))
-
-
-(define-parse-method string-list ()
- (make-instance 'string-list))
-
-(defmethod translate-to-foreign (sequence (type string-list))
- (let ((string-list (qt-smoke-make-string-list)))
- (map nil #'(lambda (string)
- (with-foreign-string ((data length) string :null-terminated-p nil)
- (qt-smoke-string-list-append string-list data length)))
- sequence)
- string-list))
-
-
-(defmethod translate-from-foreign (string-list (type string-list))
- (let ((vector (make-array (qt-smoke-string-list-size string-list))))
+(defun from-string-list (string-list)
+ (let ((vector (make-array (qt-smoke-string-list-size string-list)
+ :initial-element ""
+ :element-type 'string)))
hunk ./src/string-list.lisp 29
+ [_$_]
+(define-to-lisp-translation ("QStringList" "const QStringList&")
+ from-string-list qt-smoke-free-string-list)
hunk ./src/string-list.lisp 33
-(defmethod free-translated-object (string-list (type string-list) param)
- (declare (ignore param))
- (qt-smoke-free-string-list string-list))
-
-(defun coerce-string-list (list)
- (make-cleanup-pointer
- (translate-to-foreign list (make-instance 'string-list))
- #'(lambda (pointer)
- (free-translated-object pointer (make-instance 'string-list)
- nil))))
+(defun coerce-string-list (sequence)
+ (let ((string-list (qt-smoke-make-string-list)))
+ (map nil
+ #'(lambda (string)
+ (with-foreign-string ((data length) string :null-terminated-p nil)
+ (qt-smoke-string-list-append string-list data length)))
+ sequence)
+ (make-cleanup-pointer
+ string-list #'qt-smoke-free-string-list)))