Permalink
Browse files

Test and fix for QWebView construction: When caching superclass point…

…ers, be careful around cross-module casts
  • Loading branch information...
1 parent 7cede72 commit 814ec9f9aaa8bb4db5b7b4341d375a61787156ad @lichtblau lichtblau committed with David Lichteblau Dec 28, 2010
Showing with 26 additions and 4 deletions.
  1. +8 −0 call.lisp
  2. +2 −0 marshal.lisp
  3. +9 −4 meta.lisp
  4. +7 −0 test/tests.lisp
View
@@ -418,3 +418,11 @@
(funcall fun c)
(map-qclass-superclasses #'recurse c)))
(recurse class)))
+
+(defun map-cpl-using-result (fun class initial-value)
+ (labels ((recurse (c val)
+ (let ((newval (funcall fun c val)))
+ (map-qclass-superclasses
+ (lambda (sub) (recurse sub newval))
+ c))))
+ (recurse class initial-value)))
View
@@ -35,6 +35,8 @@
(if (eql module (ldb-module <to>))
<to>
(find-qclass-in-module module (qclass-name <to>)))))
+ (unless compatible-<to>
+ (error "sorry, casting across modules in several steps not yet supported"))
(values (data-castfn (data-ref module))
compatible-<to>)))
View
@@ -104,10 +104,15 @@
(let ((ptr (qobject-pointer object)))
; (assert (null (pointer->cached-object ptr)))
(setf (pointer->cached-object ptr) object)
- (map-cpl (lambda (super)
- (setf (pointer->cached-object (%cast object super))
- object))
- (qobject-class object))
+ (assert (qobject-class object))
+ (map-cpl-using-result (lambda (super casted)
+ (let ((ptr (%cast casted super)))
+ (setf (pointer->cached-object ptr) object)
+ (make-instance 'qobject
+ :class super
+ :pointer ptr)))
+ (qobject-class object)
+ object)
(when (typep object 'dynamic-object)
(setf (gethash (cffi:pointer-address ptr) *strongly-cached-objects*)
object)))
View
@@ -377,3 +377,10 @@
(assert (equal (#_objectName instance) "dummy")))
t)))
t)
+
+(deftest/qt new-qwebview
+ (progn
+ (ensure-smoke :qtwebkit)
+ (with-object (x (#_new QWebView)))
+ t)
+ t)

0 comments on commit 814ec9f

Please sign in to comment.