glib: Fix memory overwrite in translate-to-foreign for variant cstructures

[cl-gtk2.git] / glib / gobject.boxed.lisp

diff --git a/glib/gobject.boxed.lisp b/glib/gobject.boxed.lisp
index fe84adb..301e175 100644 (file)
--- a/glib/gobject.boxed.lisp
+++ b/glib/gobject.boxed.lisp
@@ -92,6 +92,8 @@
                  (for type = (cstruct-slot-description-type slot))
                  (for count = (cstruct-slot-description-count slot))
                  (collect `(,name ,type ,@(when count `(:count ,count))))))
+       (defcunion ,(generated-cunion-name name)
+         (,name ,(generated-cstruct-name name)))
        (eval-when (:compile-toplevel :load-toplevel :execute)
          (setf (get ',name 'g-boxed-foreign-info)
                (make-g-boxed-cstruct-wrapper-info :name ',name
@@ -124,15 +126,31 @@
   (iter (with cstruct-type = (generated-cstruct-name (cstruct-description-name cstruct-description)))
         (for slot in (cstruct-description-slots cstruct-description))
         (for slot-name = (cstruct-slot-description-name slot))
-        (setf (foreign-slot-value native cstruct-type slot-name)
-              (slot-value proxy slot-name))))
+        (cond
+          ((cstruct-slot-description-count slot)
+           (iter (with ptr = (foreign-slot-pointer native cstruct-type slot-name))
+                 (with array = (slot-value proxy slot-name))
+                 (for i from 0 below (cstruct-slot-description-count slot))
+                 (setf (mem-aref ptr (cstruct-slot-description-type slot) i)
+                       (aref array i))))
+          (t
+           (setf (foreign-slot-value native cstruct-type slot-name)
+                 (slot-value proxy slot-name))))))
 
 (defun copy-slots-to-proxy (proxy native cstruct-description)
   (iter (with cstruct-type = (generated-cstruct-name (cstruct-description-name cstruct-description)))
         (for slot in (cstruct-description-slots cstruct-description))
         (for slot-name = (cstruct-slot-description-name slot))
-        (setf (slot-value proxy slot-name)
-              (foreign-slot-value native cstruct-type slot-name))))
+        (cond
+          ((cstruct-slot-description-count slot)
+           (setf (slot-value proxy slot-name) (make-array (list (cstruct-slot-description-count slot))))
+           (iter (with ptr = (foreign-slot-pointer native cstruct-type slot-name))
+                 (with array = (slot-value proxy slot-name))
+                 (for i from 0 below (cstruct-slot-description-count slot))
+                 (setf (aref array i)
+                       (mem-aref ptr (cstruct-slot-description-type slot) i))))
+          (t (setf (slot-value proxy slot-name)
+                   (foreign-slot-value native cstruct-type slot-name))))))
 
 (defmethod translate-to-foreign (proxy (type boxed-cstruct-foreign-type))
   (if (null proxy)
@@ -294,13 +312,15 @@
               :structure (parse-variant-structure-definition variant-name slots parent)))
         (collect variant)))
 
+(defpackage :gobject.boxed.generated-names)
+
 (defun generated-cstruct-name (symbol)
   (or (get symbol 'generated-cstruct-name)
-      (setf (get symbol 'generated-cstruct-name) (gensym (format nil "GEN-~A-CSTRUCT-" (symbol-name symbol))))))
+      (setf (get symbol 'generated-cstruct-name) (gentemp (format nil "CSTRUCT-~A" (symbol-name symbol)) (find-package :gobject.boxed.generated-names)))))
 
 (defun generated-cunion-name (symbol)
   (or (get symbol 'generated-cunion-name)
-      (setf (get symbol 'generated-cunion-name) (gensym (format nil "GEN-~A-CUNION-" (symbol-name symbol))))))
+      (setf (get symbol 'generated-cunion-name) (gentemp (format nil "CUNION-~A" (symbol-name symbol)) (find-package :gobject.boxed.generated-names)))))
 
 (defun generate-cstruct-1 (struct)
   `(defcstruct ,(generated-cstruct-name (cstruct-description-name struct))
@@ -368,11 +388,13 @@
 (defun generate-proxy-type-decision-procedure (str)
   (let ((native (gensym "NATIVE-")))
     `(lambda (,native)
+       (declare (ignorable ,native))
        ,(generate-proxy-type-decision-procedure-1 str native))))
 
 (defun generate-native-type-decision-procedure (str)
   (let ((proxy (gensym "PROXY-")))
     `(lambda (,proxy)
+       (declare (ignorable ,proxy))
        ,(generate-native-type-decision-procedure-1 str proxy))))
 
 (defun compile-proxy-type-decision-procedure (str)
@@ -431,7 +453,7 @@
       (null-pointer)
       (let* ((type (g-boxed-foreign-info foreign-type))
              (cstruct-description (decide-native-type type proxy)))
-        (with-foreign-object (native-structure (generated-cstruct-name
+        (with-foreign-object (native-structure (generated-cunion-name
                                                 (var-structure-name
                                                  (g-boxed-variant-cstruct-info-root type))))
           (copy-slots-to-native proxy native-structure cstruct-description)
@@ -444,12 +466,13 @@
   (when proxy
     (let ((type (g-boxed-foreign-info foreign-type)))
       (multiple-value-bind (actual-struct cstruct-description) (decide-proxy-type type native)
-        (unless (eq (type-of proxy) (cstruct-description-name actual-struct))
+        (unless (eq (type-of proxy) actual-struct)
           (restart-case
               (error "Expected type of boxed variant structure ~A and actual type ~A do not match"
                      (type-of proxy) actual-struct)
             (skip-parsing-values () (return-from free-translated-object))))
-        (copy-slots-to-proxy proxy native cstruct-description)))))
+        (copy-slots-to-proxy proxy native cstruct-description)
+        (boxed-free-fn type native)))))
 
 (defmethod translate-from-foreign (native (foreign-type boxed-variant-cstruct-foreign-type))
   (unless (null-pointer-p native)