src/object.lisp
Sun Jan 10 09:52:49 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Split up in qt.gui & cleanup name prefix.
--- old-qt.gui/src/object.lisp 2014-10-30 07:42:15.000000000 +0100
+++ new-qt.gui/src/object.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,247 +0,0 @@
-(in-package :cl-smoke.qt-impl)
-
-;; 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))))
-
-(defmethod cxx:static-meta-object ((class cxx:class))
- (cxx:static-meta-object (smoke::find-smoke-class class)))
-
-(defmethod documentation :around ((class smoke::smoke-standard-class)
- (doc-type (eql 't)))
- (if (and (subtypep class (find-class 'qt:object))
- (not (subtypep class (find-class 'cxx:class))))
- (format nil "~@[~A~%~]Properties:~%~T~{~<~%~T~0,75:; ~(~A~)~>~}
-
-Signals:
-~{~T~A~%~}
-Slots:
-~{~T~A~%~}"
- (call-next-method) (sort (qt:class-direct-properties class) #'string<=)
- (sort (class-signals class) #'string<=)
- (sort (class-slots class) #'string<=))
- (call-next-method)))
-
-(defmethod print-object ((object qt:object) stream)
- (if (or (not (slot-boundp object 'pointer))
- (null-pointer-p (pointer object)))
- (call-next-method)
- (if (string= "" (cxx:object-name object))
- (print-unreadable-object (object stream :type t :identity t)
- (when (smoke::const-p object)
- (princ "CONST " stream)))
- (print-unreadable-object (object stream :type t :identity t)
- (when (smoke::const-p object)
- (princ "CONST " stream))
- (princ (cxx:object-name object) stream)))))
-
-(defmethod print-object ((object qt:meta-object) stream)
- (if (or (not (slot-boundp object 'pointer))
- (null-pointer-p (pointer object)))
- (call-next-method)
- (print-unreadable-object (object stream :type t :identity t)
- (princ (cxx:class-name object) stream))))
-
-(defun meta-object-methods (meta-object &optional (direct-only nil))
- (loop for index from (if direct-only (cxx:method-offset meta-object) 0)
- below (cxx:method-count meta-object)
- collect (cxx:method meta-object index)))
-
-
-(defun meta-object-signals (meta-object &key all)
- (mapcar #'cxx:signature
- (remove-if-not #'(lambda (m) (enum= qt:meta-method.+signal+
- (cxx:method-type m)))
- (meta-object-methods meta-object (not all)))))
-
-(defun class-signals (class &key all)
- (meta-object-signals (cxx:static-meta-object class) :all all))
-
-(defun meta-object-slots (meta-object &key all)
- (mapcar #'cxx:signature
- (remove-if-not #'(lambda (m) (enum= qt:meta-method.+slot+
- (cxx:method-type m)))
- (meta-object-methods meta-object (not all)))))
-
-
-(defun class-slots (class &key all)
- (meta-object-slots (cxx:static-meta-object class) :all all))
-
-(defun parent-p (object)
- (not (null-pointer-p (smoke::pointer-call
- (smoke::make-smoke-method-from-name
- (find-class 'qt:object)
- "parent")
- (smoke::pointer object)))))
-
-
-;; FIXME this might not be that smart.
-(eval-startup (:compile-toplevel :execute)
- (defparameter *destroyed-slot* (qt:make-slot
- #'(lambda (object)
- (foreign-funcall-pointer
- (get-callback 'smoke::destructed)
- () :pointer (smoke:pointer object))))))
-
-(defvar *toplevel-objects* nil)
-
-(defun ensure-smoke-parent (object)
- (declare (optimize (speed 3)))
- (let ((parent (cxx:parent 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)
- (if (null-pointer-p (smoke:pointer (cxx:parent parent)))
- (push parent *toplevel-objects*)
- (smoke::transfer-ownership-to parent (ensure-smoke-parent parent))))
- parent))
-
-(defmethod initialize-instance :after ((object qt:object)
- &key (pointer nil pointer-p) &allow-other-keys)
- "Registers the object to the parent when a parent was set in the constructor
-and the objects metaclass is SMOKE-WRAPPER-CLASS."
- (declare (optimize (speed 3)))
- (when (and (not pointer-p)
- (null-pointer-p (smoke::pointer object)))
- (error "Object ~A has not been constructed" object))
- (when (and (null pointer)
- (not (null-pointer-p (smoke::pointer object)))
- (parent-p object))
- (smoke::transfer-ownership-to object
- (ensure-smoke-parent object))))
-
-(define-condition wrapper-gc (storage-condition)
- ((object-class :initarg :object-class
- :documentation "The class of the gc'ed object.")
- (pointer :initarg :pointer))
- (:report (lambda (condition stream)
- (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)))))
-
-(eval-startup (:compile-toplevel :execute)
- (defparameter *get-parent*
- (smoke::make-smoke-method-from-name (find-class 'qt:object) "parent"))
-
- ;; FIXME this leaks memory when QCoreApplication::exec() is never
- ;; called, beause then, deleteLater() has no effect.
- (defparameter *delete-later*
- (smoke::make-smoke-method-from-name (find-class 'qt:object) "deleteLater")))
-
-(defmethod smoke::make-finalize ((object qt:object))
- "Delete the qt:object OBJECT,
- by calling cxx:delete-later iff it has no parent."
- (let ((pointer (pointer object))
- (class (class-of object))
- (next (call-next-method)))
- (declare (function next))
- (if (typep (class-of object) 'cxx:class)
- #'(lambda ()
- (declare (optimize (speed 3)))
- (handler-case
- (if (null-pointer-p (smoke::pointer-call *get-parent* pointer))
- (smoke::pointer-call *delete-later* pointer)
- (error (make-condition 'wrapper-gc
- :object-class class
- :pointer pointer)))
- (error (condition)
- (smoke::report-finalize-error condition "qt:object wrap"
- (name class) pointer))))
- #'(lambda ()
- (declare (optimize (speed 3)))
- (handler-case
- (if (null-pointer-p (smoke::pointer-call *get-parent* pointer))
- (funcall next)
- (cerror "Ignore" "Finalizer for object with a parent called."))
- (error (condition)
- (smoke::report-finalize-error condition "qt:object"
- (name class) pointer)))))))
-
-
-;;;
-;;; The event-notify callback get called by QCoreApplication, on
-;;; notification of an event.
-;;;
-;;; The DATA argument is an array of size three, containing the
-;;; pointers:
-;;;
-;;; void* receiver
-;;; void* event
-;;; void* result
-;;; in that order.
-;;;
-;;; Returning true marks the event as handled; false on the other hand
-;;; leaves the event processing unchanged.
-;;;
-;;; See: QCoreApplication::notifyInternal(QObject *receiver, QEvent
-;;; *event)
-
-(cffi:defcallback event-notify smoke:cxx-bool
- ((data :pointer))
- (declare (optimize (speed 3)))
- (let ((receiver (smoke::get-object (cffi:mem-aref data :pointer 0)))
- (event (cast-event
- (make-instance 'qt:event
- :pointer (cffi:mem-aref data :pointer 1)))))
- (enum-case (cxx:type event)
- (qt:event.+child-added+
- (tg:cancel-finalization (cxx:child event))
- (when (smoke::has-pointer-p (smoke::pointer (cxx:child event)))
- (unless receiver
- (setf receiver (ensure-smoke-parent (cxx:child event))))
- (smoke::transfer-ownership-to (cxx:child event) receiver)))
- (qt:event.+child-removed+
- ;; We receive child removed events for any QObject, whether
- ;; it was constructed by Smoke or not. Only take ownership of
- ;; objects that have been constructed by Smoke.
- (when (smoke::has-pointer-p (smoke::pointer (cxx:child event)))
- (assert receiver)
- (smoke::take-ownership (cxx:child event) receiver)))))
- nil)
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (cffi:defcfun qt-smoke-register-event-notify :boolean
- (event-notify :pointer)))
-
-(defun register-event-notify ()
- (let ((ret (qt-smoke-register-event-notify (cffi:callback event-notify))))
- (unless ret
- (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))))))
-
-(eval-startup ()
- (register-event-notify))