/[cffi-objects]/object.lisp
ViewVC logotype

Contents of /object.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 12 - (hide annotations)
Sun Oct 7 11:59:54 2012 UTC (18 months, 1 week ago) by rklochkov
File size: 5520 byte(s)
Fixed double free of object due to use of with-slots instead of setf (pointer object)
1 rklochkov 1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2     ;;;
3     ;;; object.lisp --- CFFI type OBJECT
4     ;;;
5     ;;; Copyright (C) 2007, Roman Klochkov <monk@slavsoft.surgut.ru>
6     ;;;
7    
8     (in-package :cffi-objects)
9    
10     (defvar *objects* (make-hash-table)
11     "Hash table: foreign-pointer address as integer -> lisp object")
12    
13     (defvar *objects-ids* (make-hash-table)
14     "Hash table: atom -> lisp object")
15    
16     (defclass object ()
17     ((pointer :accessor pointer :initarg :pointer
18     :initform (null-pointer) :type foreign-pointer)
19     ;; by default object shouldn't be stored unless it is GtkObject
20     (volatile :type boolean :accessor volatile
21     :initarg :volatile :initform t
22     :documentation "Will not be saved in hash")
23     (free-after :type boolean :initarg :free-after :initform t
24 rklochkov 12 :documentation "Should be freed by finalizer or FREE")
25 rklochkov 7 (initialized :type list :initform nil
26 rklochkov 12 :documentation "For SETF-INIT. To avoid double init")
27 rklochkov 1 (id :type symbol :accessor id :initarg :id :initform nil))
28     (:documentation "Lisp wrapper for any object. VOLATILE slot set when object
29     shouldn't be stored in *OBJECTS*. Stored pointer GC'ed, if VOLATILE."))
30    
31     (defmethod (setf pointer) :after (value (object object))
32     (declare (type foreign-pointer value))
33     (tg:cancel-finalization object)
34 rklochkov 12 ;(format t "Set pointer: ~a~%" object)
35 rklochkov 1 (when (and (slot-value object 'free-after) (not (null-pointer-p value)))
36     (let ((class (class-of object)))
37 rklochkov 3 (format t "Set finalizer: ~a ~a ~a~%" object class value)
38     (tg:finalize object (lambda ()
39     (format t "Finalize: ~a ~a~%" class value)
40 rklochkov 1 (free-ptr class value)))))
41     ; specialize EQL CLASS to override
42     (unless (or (volatile object) (null-pointer-p value))
43     (setf (gethash (pointer-address value) *objects*) object)
44     (when (id object)
45     (let ((cur-obj (gethash (id object) *objects-ids*)))
46     (unless (or (null cur-obj) (eq cur-obj object))
47     (warn "ID ~a for object ~a already set for ~a~%"
48     (id object) object (gethash (id object) *objects-ids*)))
49     (setf (gethash (id object) *objects-ids*) object)))))
50    
51     (defgeneric gconstructor (object &rest initargs)
52     (:documentation "Called during initialization of OBJECT instance.
53     Should return a pointer to foreign OBJECT instance,
54     for example, by g_object_new."))
55    
56     (defmethod gconstructor (something-bad &rest rest)
57     (warn "No constructor for ~a ~a~%" something-bad rest))
58    
59     (defmethod shared-initialize :after ((object object) slot-names
60     &rest initargs
61     &key pointer &allow-other-keys)
62     (unless pointer
63     (setf (pointer object) (apply #'gconstructor object initargs))))
64    
65     (defmethod pointer (something-bad)
66     (declare (ignore something-bad))
67     "Empty method to return null-pointer for non-objects"
68     (null-pointer))
69    
70     (defgeneric free (object)
71     (:documentation "Removes object pointer from lisp hashes."))
72    
73     (defmethod free ((object object))
74 rklochkov 12 ;(format t "Called free ~a~%" object)
75 rklochkov 11 (with-slots (id pointer free-after) object
76     (unless (null-pointer-p pointer)
77     (remhash (pointer-address pointer) *objects*)
78     (remhash id *objects-ids*)
79     (when free-after
80     (free-ptr (class-of object) pointer))
81 rklochkov 12 ;; if use (setf pointer (null-pointer)) then
82     ;; (setf pointer) method is not called
83     (setf (pointer object) (null-pointer)
84 rklochkov 11 id nil))))
85 rklochkov 1
86     (defun find-object (pointer &optional class)
87     "Returns lisp object for an Object pointer.
88     If not found or found with wrong class, create new one with given CLASS"
89     (declare (type symbol class) (type foreign-pointer pointer))
90     (unless (null-pointer-p pointer)
91 rklochkov 3 (let ((try-find (gethash (pointer-address pointer) *objects*)))
92 rklochkov 1 (if class
93     (progn
94     (unless (or (null try-find)
95     (eq (class-of try-find) (find-class class)))
96     (progn
97     (free try-find)
98     (setf try-find nil)))
99 rklochkov 3 (or try-find (make-instance class
100     :pointer pointer
101     :free-after nil)))
102 rklochkov 4 (or try-find pointer)))))
103 rklochkov 1
104     (defun object-by-id (id-key)
105     (gethash id-key *objects-ids*))
106    
107     ;; Type OBJECT
108     ;; converts class object to pointer and vice versa
109    
110     (define-foreign-type cffi-object ()
111     ((class :initarg :class :accessor object-class))
112     (:actual-type :pointer))
113    
114     (define-parse-method object (&optional class)
115     (make-instance 'cffi-object :class class))
116    
117     (defmethod translate-to-foreign ((value null) (type cffi-object))
118     (null-pointer))
119    
120     (defmethod translate-to-foreign ((value object) (type cffi-object))
121     (pointer value))
122    
123     ;; Hack: redefine translator for :pointer to be able to use
124     ;; objects or nulls instead of pointer
125     (defmethod translate-to-foreign ((value object)
126     (type cffi::foreign-pointer-type))
127     (pointer value))
128    
129     (defmethod translate-to-foreign ((value null)
130     (type cffi::foreign-pointer-type))
131     (null-pointer))
132    
133 rklochkov 3 ;; nil = null string
134     (defmethod translate-to-foreign ((value null)
135     (type cffi::foreign-string-type))
136     (null-pointer))
137    
138    
139 rklochkov 1 (defmethod translate-to-foreign (value (type cffi-object))
140     (check-type value foreign-pointer)
141     value)
142    
143     (defmethod translate-from-foreign (ptr (cffi-object cffi-object))
144 rklochkov 5 (find-object ptr (object-class cffi-object)))

  ViewVC Help
Powered by ViewVC 1.1.5