chiark / gitweb /
a722174e7f2fdb639eb7dfd1c700b08f3a1d3bf3
[clg] / glib / gobject.lisp
1 ;; Common Lisp bindings for GTK+ v2.0
2 ;; Copyright (C) 2000-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
3 ;;
4 ;; This library is free software; you can redistribute it and/or
5 ;; modify it under the terms of the GNU Lesser General Public
6 ;; License as published by the Free Software Foundation; either
7 ;; version 2 of the License, or (at your option) any later version.
8 ;;
9 ;; This library is distributed in the hope that it will be useful,
10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
12 ;; Lesser General Public License for more details.
13 ;;
14 ;; You should have received a copy of the GNU Lesser General Public
15 ;; License along with this library; if not, write to the Free Software
16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
17
18 ;; $Id: gobject.lisp,v 1.30 2005-02-01 15:24:52 espen Exp $
19
20 (in-package "GLIB")
21
22
23 ;;;; Metaclass used for subclasses of gobject
24
25 (eval-when (:compile-toplevel :load-toplevel :execute)
26   (defclass gobject-class (ginstance-class)
27     ())
28
29   (defmethod validate-superclass ((class gobject-class)
30                                 (super pcl::standard-class))
31 ;  (subtypep (class-name super) 'gobject)
32     t))
33
34 (defclass direct-property-slot-definition (direct-virtual-slot-definition)
35   ((pname :reader slot-definition-pname :initarg :pname)
36    (readable :initform t :reader slot-readable-p :initarg :readable)
37    (writable :initform t :reader slot-writable-p :initarg :writable)
38    (construct :initform nil :initarg :construct)))
39
40 (defclass effective-property-slot-definition (effective-virtual-slot-definition)
41   ((pname :reader slot-definition-pname :initarg :pname)
42    (readable :reader slot-readable-p :initarg :readable)
43    (writable :reader slot-writable-p :initarg :writable)
44    (construct :initarg :construct)))
45
46 (defclass direct-user-data-slot-definition (direct-virtual-slot-definition)
47   ())
48
49 (defclass effective-user-data-slot-definition (effective-virtual-slot-definition)
50   ())
51
52
53 (defbinding %object-ref () pointer
54   (location pointer))
55
56 (defbinding %object-unref () nil
57   (location pointer))
58
59 (defmethod reference-foreign ((class gobject-class) location)
60   (declare (ignore class))
61   (%object-ref location))
62
63 (defmethod unreference-foreign ((class gobject-class) location)
64   (declare (ignore class))
65   (%object-unref location))
66
67
68 ; (defbinding object-class-install-param () nil
69 ;   (class pointer)
70 ;   (id unsigned-int)
71 ;   (parameter parameter))
72
73 ; (defbinding object-class-find-param-spec () parameter
74 ;   (class pointer)
75 ;   (name string))
76
77 (defun signal-name-to-string (name)
78   (substitute #\_ #\- (string-downcase (string name))))
79
80
81 (defmethod direct-slot-definition-class ((class gobject-class) &rest initargs)
82   (case (getf initargs :allocation)
83     (:property (find-class 'direct-property-slot-definition))
84     (:user-data (find-class 'direct-user-data-slot-definition))
85     (t (call-next-method))))
86
87 (defmethod effective-slot-definition-class ((class gobject-class) &rest initargs)
88   (case (getf initargs :allocation)
89     (:property (find-class 'effective-property-slot-definition))
90     (:user-data (find-class 'effective-user-data-slot-definition))
91     (t (call-next-method))))
92
93 (defmethod compute-effective-slot-definition-initargs ((class gobject-class) direct-slotds)
94   (if (typep (first direct-slotds) 'direct-property-slot-definition)
95       (nconc 
96        (list :pname (signal-name-to-string 
97                      (most-specific-slot-value direct-slotds 'pname))
98              :readable (most-specific-slot-value direct-slotds 'readable)
99              :writable (most-specific-slot-value direct-slotds 'writable)
100              :construct (most-specific-slot-value direct-slotds 'construct))
101        (call-next-method))
102     (call-next-method)))
103
104
105 (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-definition))
106   (let* ((type (slot-definition-type slotd))
107          (pname (slot-definition-pname slotd))
108          (type-number (find-type-number type)))
109     (when (and (not (slot-boundp slotd 'getter)) (slot-readable-p slotd))
110       (setf 
111        (slot-value slotd 'getter)
112        (let ((reader nil))
113          #'(lambda (object)
114              (unless reader
115                (setq reader (reader-function type))) ;(type-from-number type-number))))
116              (let ((gvalue (gvalue-new type-number)))
117                (%object-get-property object pname gvalue)
118                (unwind-protect
119                  (funcall reader  gvalue +gvalue-value-offset+)
120                  (gvalue-free gvalue t)))))))
121     
122     (when (and (not (slot-boundp slotd 'setter)) (slot-writable-p slotd))
123       (setf 
124        (slot-value slotd 'setter)
125        (let ((writer nil))
126          #'(lambda (value object)
127              (unless writer
128                (setq writer (writer-function type))) ;(type-from-number type-number))))
129              (let ((gvalue (gvalue-new type-number)))
130                (funcall writer value gvalue +gvalue-value-offset+)
131                (%object-set-property object pname gvalue)
132                (gvalue-free gvalue t)
133                value))))))
134
135   (call-next-method))
136
137 (defmethod initialize-internal-slot-functions ((slotd effective-user-data-slot-definition))
138   (let ((slot-name (slot-definition-name slotd)))
139     (unless (slot-boundp slotd 'getter)
140       (setf 
141        (slot-value slotd 'getter)
142        #'(lambda (object)
143            (prog1 (user-data object slot-name)))))
144     (unless (slot-boundp slotd 'setter)
145       (setf 
146        (slot-value slotd 'setter)
147        #'(lambda (value object)
148            (setf (user-data object slot-name) value))))
149     (unless (slot-boundp slotd 'boundp)
150       (setf 
151        (slot-value slotd 'boundp)
152        #'(lambda (object)
153            (user-data-p object slot-name)))))
154   (call-next-method))
155
156
157 ;;;; Super class for all classes in the GObject type hierarchy
158
159 (eval-when (:compile-toplevel :load-toplevel :execute)
160   (defclass gobject (ginstance)
161     ()
162     (:metaclass gobject-class)
163     (:alien-name "GObject")))
164
165
166 (defun initial-add (object function initargs key pkey)
167   (loop 
168    as (initarg value . rest) = initargs then rest
169    do (cond
170        ((eq initarg key) (funcall function object value))
171        ((eq initarg pkey) (mapc #'(lambda (value)
172                                     (funcall function object value))
173                                 value)))
174        while rest))
175
176 (defun initial-apply-add (object function initargs key pkey)
177   (initial-add object #'(lambda (object value)
178                           (apply function object (mklist value)))
179                initargs key pkey))
180
181
182 (defmethod initialize-instance ((object gobject) &rest initargs)
183   (unless (slot-boundp object 'location)
184     ;; Extract initargs which we should pass directly to the GObeject
185     ;; constructor
186     (let* ((slotds (class-slots (class-of object)))
187            (args (when initargs
188                    (loop 
189                     as (key value . rest) = initargs then rest
190                     as slotd = (find-if
191                                 #'(lambda (slotd)
192                                     (member key (slot-definition-initargs slotd)))
193                                 slotds)
194                     when (and (typep slotd 'effective-property-slot-definition)
195                               (slot-value slotd 'construct))
196                     collect (progn 
197                               (remf initargs key)
198                               (list 
199                                (slot-definition-pname slotd)
200                                (slot-definition-type slotd)
201                                value))
202                     while rest))))
203       (if args
204           (let* ((string-size (size-of 'string))
205                  (string-writer (writer-function 'string))
206                  (string-destroy (destroy-function 'string))
207                  (params (allocate-memory 
208                           (* (length args) (+ string-size +gvalue-size+)))))
209             (loop
210              for (pname type value) in args
211              as tmp = params then (sap+ tmp (+ string-size +gvalue-size+))
212              do (funcall string-writer pname tmp)
213              (gvalue-init (sap+ tmp string-size) type value))
214             (unwind-protect
215                 (setf  
216                  (slot-value object 'location) 
217                  (%gobject-newv (type-number-of object) (length args) params))
218               (loop
219                repeat (length args)
220                as tmp = params then (sap+ tmp (+ string-size +gvalue-size+))
221                do (funcall string-destroy tmp)
222                (gvalue-unset (sap+ tmp string-size)))
223               (deallocate-memory params)))
224         (setf  
225          (slot-value object 'location) 
226          (%gobject-new (type-number-of object))))))
227
228   (apply #'call-next-method object initargs))
229
230
231 (defmethod instance-finalizer ((instance gobject))
232   (let ((location (proxy-location instance)))
233     #'(lambda ()
234         (remove-cached-instance location)
235         (%object-unref location))))
236
237
238 (defbinding (%gobject-new "g_object_new") () pointer
239   (type type-number)
240   (nil null))
241
242 (defbinding (%gobject-newv "g_object_newv") () pointer
243   (type type-number)
244   (n-parameters unsigned-int)
245   (params pointer))
246
247
248
249 ;;;; Property stuff
250
251 (defbinding %object-set-property () nil
252   (object gobject)
253   (name string)
254   (value gvalue))
255
256 (defbinding %object-get-property () nil
257   (object gobject)
258   (name string)
259   (value gvalue))
260
261 (defbinding %object-notify () nil
262   (object gobject)
263   (name string))
264
265 (defbinding object-freeze-notify () nil
266   (object gobject))
267
268 (defbinding object-thaw-notify () nil
269   (object gobject))
270
271
272 ;;;; User data
273
274 (defbinding %object-set-qdata-full () nil
275   (object gobject)
276   (id quark)
277   (data unsigned-long)
278   (destroy-marshal pointer))
279
280 (defun (setf user-data) (data object key)
281   (%object-set-qdata-full object (quark-intern key)
282    (register-user-data data) (callback %destroy-user-data))
283   data)
284
285 ;; deprecated
286 (defun (setf object-data) (data object key &key (test #'eq))
287   (assert (eq test #'eq))
288   (setf (user-data object key) data))
289
290 (defbinding %object-get-qdata () unsigned-long
291   (object gobject)               
292   (id quark))
293
294 (defun user-data (object key)
295   (find-user-data (%object-get-qdata object (quark-intern key))))
296
297 ;; deprecated
298 (defun object-data (object key &key (test #'eq))
299   (assert (eq test #'eq))
300   (user-data object key))
301
302 (defun user-data-p (object key)
303   (user-data-exists-p (%object-get-qdata object (quark-intern key))))
304
305 (defbinding %object-steal-qdata () unsigned-long
306   (object gobject)               
307   (id quark))
308
309 (defun unset-user-data (object key)
310   (destroy-user-data (%object-steal-qdata object (quark-intern key))))
311
312
313 ;;;;
314
315 (defbinding %object-class-list-properties () pointer
316   (class pointer)
317   (n-properties unsigned-int :out))
318
319
320 (defun %map-params (params length type inherited-p)
321   (if inherited-p
322       (map-c-vector 'list #'identity params 'param length)
323     (let ((properties ()))
324       (map-c-vector 'list 
325        #'(lambda (param)
326            (when (eql (param-owner-type param) type)
327              (push param properties)))
328        params 'param length)
329       (nreverse properties))))
330
331 (defun query-object-class-properties (type &optional inherited-p)
332   (let* ((type-number (find-type-number type))
333          (class (type-class-ref type-number)))
334     (unwind-protect
335          (multiple-value-bind (array length)
336              (%object-class-list-properties class)
337            (unwind-protect
338                 (%map-params array length type-number inherited-p)
339              (deallocate-memory array)))
340 ;      (type-class-unref type-number)
341       )))
342
343
344 (defun default-slot-name (name)
345   (intern (substitute #\- #\_ (string-upcase (string-upcase name)))))
346
347 (defun default-slot-accessor (class-name slot-name type)
348   (intern
349    (format
350     nil "~A-~A~A" class-name slot-name
351     (if (eq type 'boolean) "-P" ""))))
352
353
354 (defun slot-definition-from-property (class property &optional slot-name args)
355   (with-slots (name flags value-type documentation) property
356     (let* ((slot-name (or slot-name (default-slot-name name)))
357            (slot-type (or (getf args :type) (type-from-number value-type) 'pointer))
358            (accessor (default-slot-accessor class slot-name slot-type)))
359       
360       `(,slot-name
361         :allocation :property :pname ,name
362
363         ,@(cond
364            ((find :unbound args) (list :unbound (getf args :unbound))))
365         
366         ;; accessors
367         ,@(cond
368            ((and
369              (member :writable flags) (member :readable flags)
370              (not (member :construct-only flags)))
371             (list :accessor accessor))
372            ((and (member :writable flags) (not (member :construct-only flags)))
373             (list :writer `(setf ,accessor)))
374            ((member :readable flags)
375             (list :reader accessor)))
376
377         ;; readable/writable/construct
378         ,@(when (or (not (member :writable flags))
379                     (member :construct-only flags))
380             '(:writable nil))
381         ,@(when (not (member :readable flags))
382             '(:readable nil))
383         ,@(when (or (member :construct flags) 
384                     (member :construct-only flags))
385             '(:construct t))
386         
387         ;; initargs
388         ,@(when (or (member :construct flags)
389                     (member :construct-only flags)
390                     (member :writable flags))
391             (list :initarg (intern (string slot-name) "KEYWORD")))
392         ,@(cond
393            ((find :initarg args) (list :initarg (getf args :initarg))))
394         
395         :type ,slot-type
396         :documentation ,documentation))))
397
398
399 (defun slot-definitions (class properties slots)
400   (loop 
401    for property in properties
402    as slot = (or
403               (find (param-name property) slots 
404                :key #'(lambda (slot) (getf (rest slot) :pname)) 
405                :test #'string=)
406               (find (param-name property) slots 
407                :key #'first :test #'string-equal))
408    do (cond
409        ((not slot) 
410         (push (slot-definition-from-property class property) slots))
411        ((getf (rest slot) :merge)
412         (setf 
413          (rest slot) 
414          (rest (slot-definition-from-property class property (first slot) (rest slot)))))))
415   (delete-if #'(lambda (slot) (getf (rest slot) :ignore)) slots))
416
417
418 (defun expand-gobject-type (type forward-p options &optional (metaclass 'gobject-class))
419   (let ((supers (cons (supertype type) (implements type)))
420         (class  (type-from-number type))
421         (slots (getf options :slots)))    
422     `(defclass ,class ,supers
423        ,(unless forward-p
424           (slot-definitions class (query-object-class-properties type) slots))
425       (:metaclass ,metaclass)
426       (:alien-name ,(find-type-name type)))))
427
428 (defun gobject-dependencies (type)
429   (delete-duplicates (mapcar #'param-value-type (query-object-class-properties type))))
430
431
432 (register-derivable-type 'gobject "GObject" 'expand-gobject-type 'gobject-dependencies)
433
434
435 ;;; Pseudo type for gobject instances which have their reference count
436 ;;; increased by the returning function
437
438 (defmethod alien-type ((type (eql 'referenced)) &rest args)
439   (declare (ignore type args))
440   (alien-type 'gobject))
441
442 (defmethod from-alien-form (form (type (eql 'referenced)) &rest args)
443   (declare (ignore type))
444   (destructuring-bind (type) args
445     (if (subtypep type 'gobject)
446         (let ((instance (make-symbol "INSTANCE")))
447           `(let ((,instance ,(from-alien-form form type)))
448              (when ,instance
449                (%object-unref (proxy-location ,instance)))
450              ,instance))
451       (error "~A is not a subclass of GOBJECT" type))))
452
453 (export 'referenced)