src/object.lisp
Sun Apr 5 19:56:16 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* initial import
--- old-qt.core/src/object.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/object.lisp 2014-11-11 13:37:15.000000000 +0100
@@ -0,0 +1,190 @@
+(in-package :qt)
+(declaim (optimize (debug 3)))
+
+(let ((object (make-instance 'object)))
+ (defmethod cxx:static-meta-object ((class (eql (find-class 'object))) &rest args)
+ "No OBJECT.STATIC-META-OBJECT (r558420)."
+ (declare (ignore args))
+ (cxx:meta-object object))
+ (defmethod cxx:static-meta-object ((class smoke::smoke-wrapper-class) &rest args)
+ (declare (ignore args))
+ (cxx:static-meta-object (smoke::find-smoke-class class))))
+
+(defmethod documentation :around ((class smoke::smoke-standard-class)
+ (doc-type t))
+ (if (and (subtypep class (find-class 'object))
+ (not (subtypep class (find-class 'smoke::smoke-wrapper-class))))
+ (format nil "~@[~A~%~]Properties:~%~T~{~<~%~T~0,75:; ~(~A~)~>~}
+
+Signals:
+~{~T~A~%~}
+Slots:
+~{~T~A~%~}"
+ (call-next-method) (sort (class-properties class) #'string<=)
+ (sort (class-signals class) #'string<=)
+ (sort (class-slots class) #'string<=))
+ (call-next-method)))
+
+(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)
+ (mapcar #'cxx:signature
+ (remove-if-not #'(lambda (m) (enum= qt:meta-method.+signal+
+ (cxx:method-type m)))
+ (meta-object-methods meta-object))))
+
+(defun class-signals (class)
+ (meta-object-signals (cxx:static-meta-object class)))
+
+(defun meta-object-slots (meta-object)
+ (mapcar #'cxx:signature
+ (remove-if-not #'(lambda (m) (enum= qt:meta-method.+slot+
+ (cxx:method-type m)))
+ (meta-object-methods meta-object))))
+
+
+(defun class-slots (class)
+ (meta-object-slots (cxx:static-meta-object class)))
+
+
+(defvar *children* (make-hash-table)
+ "A list of custom subclasses of QObject which have a parent
+and therefor must not be garbage collected.")
+
+(defmethod initialize-instance :after ((object object)
+ &key pointer &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."
+ (when (and (null pointer)
+ (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)))
+; (typep (class-of object) 'smoke::smoke-wrapper-class)
+ (not (null-pointer-p (smoke::pointer (cxx:parent object)))))
+ (setf (gethash (smoke::pointer object) *children*) object)))
+
+(define-condition wrapper-gc (storage-condition)
+ ((class-name :initarg :class-name
+ :documentation "The class name of the gc'ed object.")
+ (pointer :initarg :pointer))
+ (:report (lambda (condition stream)
+ (format stream "The object ~A ~A of type smoke-wrapper-class
+has a parent but got garbage collected."
+ (slot-value condition 'class-name)
+ (slot-value condition 'pointer)))))
+
+(let ((get-parent (smoke::make-smoke-method (smoke::make-smoke-class
+ *qt-smoke*
+ "QObject")
+ "parent"))
+ ;; FIXME this leaks memory when QCoreApplication::exec is never called,
+ ;; beause then, deleteLater has no effect.
+ (delete-later (smoke::make-smoke-method (smoke::make-smoke-class
+ *qt-smoke*
+ "QObject")
+ "deleteLater")))
+ (defmethod smoke::make-finalize ((object object))
+ "Delete the qt:object OBJECT,
+ by calling cxx:delete-later iff it has no parent."
+ (let ((pointer (pointer object))
+ (name (class-name (class-of object)))
+ (next (call-next-method)))
+ (if (typep (class-of object) 'smoke::smoke-wrapper-class)
+ #'(lambda ()
+ (handler-case
+ (if (null-pointer-p (smoke::pointer-call get-parent pointer))
+ (smoke::pointer-call delete-later pointer)
+ (error (make-condition 'wrapper-gc :class-name name
+ :pointer pointer)))
+ (condition (condition)
+ (format *debug-io* "error: wrap finalize ~A ~A~%" name
+ condition))))
+ #'(lambda ()
+ (handler-case
+ (progn
+ (when (null-pointer-p (smoke::pointer-call get-parent pointer))
+ (funcall next)))
+ (condition (condition)
+ (format *debug-io* "error: qfinalize ~A ~A ~A~%" name
+ pointer
+ condition)))))))
+ ;(smoke::pointer-call delete-later pointer)))))))
+ )
+(defun cxx-gc ()
+ "Delete the C++ object that have been queued for deletion when
+QT:CORE-APPLICATION.EXEC is run."
+ (core-application.send-posted-events
+ (make-instance 'object :pointer (null-pointer))
+event.+deferred-delete+))
+
+
+;(defmethod upcast-object ((objeckt qobject))
+; (let ((class-name (cxx:classname (cxx:metaobject object))))
+; (if (string= class-name (name (get-class object)))
+; object
+; (let ((real-class (lispify class-name)))
+;;FIXME get smoke module from class name
+; (make-instance
+; :pointer upcast (object class))))))))
+
+
+;(defmethod upcast-object ((event qevent))
+; (case (cxx:type event)
+; (#.qevent.+childadded+
+
+;;;
+;;; 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 ((event (make-instance 'event :pointer (cffi:mem-aref data :pointer 1)
+ :owned-p nil)))
+ (enum-case (cxx:type event)
+ (event.+child-added+
+ (let* ((child-event (make-instance 'child-event
+ :pointer
+ (smoke::upcast event (find-class 'child-event))
+ :owned-p nil))
+ (child (smoke::get-object
+ (smoke::pointer (cxx:child child-event)))))
+; (when (and child
+; (typep (class-of child)
+; 'smoke::smoke-wrapper-class))
+ (when child
+ (setf (gethash (smoke::pointer child) *children*) child))))
+ (event.+child-removed+
+ (let* ((child-event (make-instance 'child-event
+ :pointer (smoke::upcast event
+ (find-class 'child-event))
+ :owned-p nil)))
+ (remhash (smoke::pointer (cxx:child child-event)) *children*)))))
+ nil)
+
+(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 "The event-notify callback table is full."))))
+
+(eval-when (:load-toplevel)
+ (register-event-notify))