repos / qt.gui / annotate_shade
summary | shortlog | log | tree | commit | commitdiff | headdiff | annotate | filehistory
normal | plain | shade | zebra
The CLISP null pointer is NIL
Annotate for file src/object.lisp
2010-01-10 tobias 1 (in-package :cl-smoke.qt-impl)
08:52:49 ' 2
2009-07-02 tobias 3 (let ((object (make-instance 'qt:object)))
19:12:45 ' 4 (defmethod cxx:static-meta-object ((class (eql (find-class 'qt:object))))
' 5 "No OBJECT.STATIC-META-OBJECT (r558420)."
' 6 (cxx:meta-object object))
' 7 (defmethod cxx:static-meta-object ((class cxx:class))
' 8 (cxx:static-meta-object (smoke::find-smoke-class class))))
2010-01-10 tobias 9
08:52:49 ' 10 (defmethod documentation :around ((class smoke::smoke-standard-class)
' 11 (doc-type (eql 't)))
' 12 (if (and (subtypep class (find-class 'qt:object))
' 13 (not (subtypep class (find-class 'cxx:class))))
' 14 (format nil "~@[~A~%~]Properties:~%~T~{~<~%~T~0,75:; ~(~A~)~>~}
' 15
' 16 Signals:
' 17 ~{~T~A~%~}
' 18 Slots:
' 19 ~{~T~A~%~}"
' 20 (call-next-method) (sort (qt:class-direct-properties class) #'string<=)
' 21 (sort (class-signals class) #'string<=)
' 22 (sort (class-slots class) #'string<=))
' 23 (call-next-method)))
' 24
' 25 (defmethod print-object ((object qt:object) stream)
' 26 (if (or (not (slot-boundp object 'pointer))
' 27 (null-pointer-p (pointer object)))
' 28 (call-next-method)
2009-08-02 tobias 29 (print-unreadable-object (object stream :type t :identity t)
11:29:13 ' 30 (princ (cxx:object-name object) stream))))
2010-01-10 tobias 31
08:52:49 ' 32 (defun meta-object-methods (meta-object &optional (direct-only nil))
' 33 (loop for index from (if direct-only (cxx:method-offset meta-object) 0)
' 34 below (cxx:method-count meta-object)
' 35 collect (cxx:method meta-object index)))
' 36
' 37
' 38 (defun meta-object-signals (meta-object &key all)
' 39 (mapcar #'cxx:signature
' 40 (remove-if-not #'(lambda (m) (enum= qt:meta-method.+signal+
' 41 (cxx:method-type m)))
' 42 (meta-object-methods meta-object (not all)))))
' 43
' 44 (defun class-signals (class &key all)
' 45 (meta-object-signals (cxx:static-meta-object class) :all all))
' 46
' 47 (defun meta-object-slots (meta-object &key all)
' 48 (mapcar #'cxx:signature
' 49 (remove-if-not #'(lambda (m) (enum= qt:meta-method.+slot+
' 50 (cxx:method-type m)))
' 51 (meta-object-methods meta-object (not all)))))
' 52
' 53
' 54 (defun class-slots (class &key all)
' 55 (meta-object-slots (cxx:static-meta-object class) :all all))
' 56
' 57 (defun parent-p (object)
2009-06-21 tobias 58 (not (null-pointer-p (smoke::pointer-call (smoke::make-smoke-method (find-class 'qt:object)
2009-08-02 tobias 59 "parent")
11:15:21 ' 60 (smoke::pointer object)))))
2010-01-10 tobias 61
2009-08-02 tobias 62 (defun find-smoke-parent (object)
11:15:21 ' 63 "Returns the first parent of OBJECT or OBJECT that is a Smoke class.
2009-06-21 tobias 64 (the destructed callback is called when the object is freed.)"
2009-08-02 tobias 65 ;; FIXME allow usage of non smoke objects by connecting to the
11:15:21 ' 66 ;; destroyed() signal.
2010-01-10 tobias 67 (let ((parent (cxx:parent object)))
2009-08-02 tobias 68 (if (not (null-pointer-p (smoke::pointer parent)))
11:15:21 ' 69 (if (smoke::has-pointer-p (smoke::pointer parent))
' 70 parent
' 71 (find-smoke-parent parent))
2009-07-08 tobias 72 (error "No smoke parent found."))))
2010-01-10 tobias 73
08:52:49 ' 74 (defmethod initialize-instance :after ((object qt:object)
2009-06-11 tobias 75 &key (pointer nil pointer-p) &allow-other-keys)
2010-01-10 tobias 76 "Registers the object to the parent when a parent was set in the constructor
08:52:49 ' 77 and the objects metaclass is SMOKE-WRAPPER-CLASS."
2009-06-11 tobias 78 (when (and (not pointer-p)
2010-01-10 tobias 79 (null-pointer-p (smoke::pointer object)))
08:52:49 ' 80 (error "Object ~A has not been constructed" object))
' 81 (when (and (null pointer)
' 82 (not (null-pointer-p (smoke::pointer object)))
' 83 (parent-p object))
' 84 (smoke::transfer-ownership-to object
2009-08-02 tobias 85 (find-smoke-parent object))))
2010-01-10 tobias 86
08:52:49 ' 87 (define-condition wrapper-gc (storage-condition)
2009-08-02 tobias 88 ((class-name :initarg :class-name
11:15:21 ' 89 :documentation "The class name of the gc'ed object.")
2010-01-10 tobias 90 (pointer :initarg :pointer))
08:52:49 ' 91 (:report (lambda (condition stream)
2009-08-02 tobias 92 (format stream "The object ~A ~A of type cxx:class
11:15:21 ' 93 has a parent but got garbage collected."
' 94 (slot-value condition 'class-name)
' 95 (slot-value condition 'pointer)))))
2010-01-10 tobias 96
2009-08-02 tobias 97 (smoke:eval-startup (:compile-toplevel :execute)
2009-07-22 tobias 98 (defparameter *get-parent*
2009-06-21 tobias 99 (smoke::make-smoke-method (smoke::make-smoke-class
09:29:25 ' 100 *qt-smoke*
' 101 "QObject")
' 102 "parent"))
2009-07-22 tobias 103 ;; FIXME this leaks memory when QCoreApplication::exec is never called,
22:21:01 ' 104 ;; beause then, deleteLater has no effect.
' 105 (defparameter *delete-later*
2009-06-21 tobias 106 (smoke::make-smoke-method (smoke::make-smoke-class
09:29:25 ' 107 *qt-smoke*
' 108 "QObject")
' 109 "deleteLater")))
' 110 (defun print-object-to-string (object)
' 111 (with-output-to-string (stream)
' 112 (print-object object stream)))
2010-01-10 tobias 113
08:52:49 ' 114 (defmethod smoke::make-finalize ((object qt:object))
2009-06-21 tobias 115 "Delete the qt:object OBJECT,
2010-01-10 tobias 116 by calling cxx:delete-later iff it has no parent."
2009-06-21 tobias 117 (let ((pointer (pointer object))
09:29:25 ' 118 (class (class-of object))
' 119 (next (call-next-method)))
' 120 (if (typep (class-of object) 'cxx:class)
' 121 #'(lambda ()
' 122 (handler-case
' 123 (if (null-pointer-p (smoke::pointer-call *get-parent* pointer))
' 124 (smoke::pointer-call *delete-later* pointer)
' 125 (error (make-condition 'wrapper-gc
' 126 :class-name (name class)
' 127 :pointer pointer)))
' 128 (error (condition)
' 129 (smoke::report-finalize-error condition "qt:object wrap"
' 130 (name class) pointer))))
' 131 #'(lambda ()
' 132 (handler-case
' 133 (if (null-pointer-p (smoke::pointer-call *get-parent* pointer))
2010-01-10 tobias 134 (funcall next)
08:52:49 ' 135 (cerror "Ignore" "Finalizer for object with a parent called."))
2009-06-21 tobias 136 (error (condition)
09:29:25 ' 137 (smoke::report-finalize-error condition "qt:object"
' 138 (name class) pointer)))))))
2010-01-10 tobias 139
08:52:49 ' 140
' 141 ;;;
2009-07-22 tobias 142 ;;; The event-notify callback get called by QCoreApplication,
22:21:01 ' 143 ;;; on notification of an event.
2010-01-10 tobias 144 ;;;
2009-07-22 tobias 145 ;;; The DATA argument is an array of size three, containing the pointers:
2010-01-10 tobias 146 ;;; void* receiver
08:52:49 ' 147 ;;; void* event
' 148 ;;; void* result
' 149 ;;; in that order.
' 150 ;;;
' 151 ;;; Returning true marks the event as handled; false on the other hand
' 152 ;;; leaves the event processing unchanged.
' 153 ;;;
2009-07-22 tobias 154 ;;; See: QCoreApplication::notifyInternal(QObject *receiver, QEvent *event)
2010-01-10 tobias 155
08:52:49 ' 156 (cffi:defcallback event-notify smoke:cxx-bool
' 157 ((data :pointer))
' 158 (declare (optimize (speed 3)))
' 159 (let ((receiver (smoke::get-object (cffi:mem-aref data :pointer 0)))
2009-08-02 tobias 160 (event (make-instance 'qt:event
11:29:02 ' 161 :pointer (cffi:mem-aref data :pointer 1))))
2010-01-10 tobias 162 (enum-case (cxx:type event)
08:52:49 ' 163 (qt:event.+child-added+
2009-08-02 tobias 164 (let ((child-event (make-instance 'qt:child-event
11:29:02 ' 165 :pointer
' 166 (smoke::upcast event (find-class 'qt:child-event)))))
' 167 (tg:cancel-finalization (cxx:child child-event))
' 168 (when (smoke::has-pointer-p (smoke::pointer (cxx:child child-event)))
' 169 (unless receiver
2009-08-02 tobias 170 (setf receiver (find-smoke-parent (cxx:child child-event))))
2009-08-02 tobias 171 (smoke::transfer-ownership-to (cxx:child child-event) receiver))))
2010-01-10 tobias 172 (qt:event.+child-removed+
2009-08-02 tobias 173 (let* ((child-event (make-instance 'qt:child-event
11:29:02 ' 174 :pointer (smoke::upcast event
' 175 (find-class 'qt:child-event)))))
2009-07-01 tobias 176 ;; We receive child removed events for any QObject, wherter
10:58:06 ' 177 ;; it was construted by Smoke or not. Only take ownership of objects
2009-07-22 tobias 178 ;; that have been constructed by Smoke.
2009-08-02 tobias 179 (when (smoke::has-pointer-p (smoke::pointer (cxx:child child-event)))
11:29:02 ' 180 (assert receiver)
' 181 (smoke::take-ownership (cxx:child child-event) receiver))))))
2010-01-10 tobias 182 nil)
08:52:49 ' 183
' 184 (eval-when (:compile-toplevel :load-toplevel :execute)
' 185 (cffi:defcfun qt-smoke-register-event-notify :boolean
' 186 (event-notify :pointer)))
' 187
' 188 (defun register-event-notify ()
' 189 (let ((ret (qt-smoke-register-event-notify (cffi:callback event-notify))))
' 190 (unless ret
2009-06-21 tobias 191 (error "The event-notify callback table is full."))))
2010-01-10 tobias 192
2009-08-02 tobias 193 (smoke:eval-startup ()
2010-01-10 tobias 194 (register-event-notify))
Crece desde el pueblo el futuro / crece desde el pie