chiark / gitweb /
Infra: Rudimentary setup system.
[clg] / gtk / gtkobject.lisp
1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
3 ;;
4 ;; Permission is hereby granted, free of charge, to any person obtaining
5 ;; a copy of this software and associated documentation files (the
6 ;; "Software"), to deal in the Software without restriction, including
7 ;; without limitation the rights to use, copy, modify, merge, publish,
8 ;; distribute, sublicense, and/or sell copies of the Software, and to
9 ;; permit persons to whom the Software is furnished to do so, subject to
10 ;; the following conditions:
11 ;;
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
14 ;;
15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
22
23 ;; $Id: gtkobject.lisp,v 1.49 2008-10-09 18:45:01 espen Exp $
24
25
26 (in-package "GTK")
27
28
29 ;;;; Superclass for the gtk class hierarchy
30
31 (eval-when (:compile-toplevel :load-toplevel :execute)
32   (init-types-in-library gtk "libgtk-2.0"))
33
34 (defclass %object (initially-unowned)
35   ()
36   (:metaclass gobject-class)
37   (:gtype |gtk_object_get_type|))
38
39
40 (defmethod initialize-instance ((object %object) &rest initargs &key signal)
41   (declare (ignore signal))
42   (call-next-method)
43   (dolist (signal-definition (get-all initargs :signal))
44     (apply #'signal-connect object signal-definition)))
45
46 #?-(pkg-exists-p "glib-2.0" :atleast-version "2.10.0")
47 (progn
48   (defmethod initialize-instance :around ((object %object) &rest initargs)
49     (declare (ignore initargs))
50     (call-next-method)
51     ;; Add a temorary reference which will be removed when the object is
52     ;; sinked
53     (funcall (reference-function '%object) (foreign-location object))
54     (%object-sink object))
55   
56   (defbinding %object-sink () nil
57     (object %object)))
58
59 ;;;; Main loop and event handling
60
61 (defparameter *reentrant-main-iteration* t)
62 (defvar *running-main-iteration* nil)
63
64 (defbinding events-pending-p () boolean)
65
66 (defbinding get-current-event () gdk:event)
67
68 (defbinding main-do-event () nil
69   (event gdk:event))
70
71 (defbinding main () nil)
72
73 (defbinding main-level () int)
74
75 (defbinding main-quit () nil)
76
77 (defbinding main-iteration-do (&optional (blocking t)) boolean
78   (blocking boolean))
79
80 (defun main-iterate-all (&rest args)
81   (declare (ignore args))
82   (unless (and (not *reentrant-main-iteration*) *running-main-iteration*)
83     (let ((*running-main-iteration* t))
84       (loop
85        while (events-pending-p)
86        do (main-iteration-do nil))))
87   #+clisp 0)
88
89
90 (define-callback fd-source-callback-marshal nil 
91     ((callback-id unsigned-int) (fd unsigned-int))
92   (glib::invoke-source-callback callback-id fd))
93
94 (defbinding (input-add "gtk_input_add_full") (fd condition function) unsigned-int
95   (fd unsigned-int)
96   (condition gdk:input-condition)
97   (fd-source-callback-marshal callback)
98   (nil null)
99   ((register-callback-function function) unsigned-long)
100   (user-data-destroy-callback callback))
101
102
103 ;;;; Metaclass for child classes
104  
105 (defvar *container-to-child-class-mappings* (make-hash-table))
106
107 (eval-when (:compile-toplevel :load-toplevel :execute)
108   (defclass container-child-class (virtual-slots-class)
109     ())
110
111   (defclass direct-child-slot-definition (direct-virtual-slot-definition)
112     ((pname :reader slot-definition-pname :initarg :pname)))
113
114   (defclass effective-child-slot-definition (effective-virtual-slot-definition)
115     ((pname :reader slot-definition-pname :initarg :pname))))
116
117
118 (defmethod shared-initialize ((class container-child-class) names &key container)
119   (declare (ignore names))
120   (call-next-method)
121   (setf
122    (gethash (find-class (first container)) *container-to-child-class-mappings*)
123     class)
124   #+clisp
125   (loop
126    for slotd in (class-direct-slots class)
127    when (typep slotd 'direct-child-slot-definition)
128    do (loop
129        for reader in (slot-definition-readers slotd)
130        do (add-reader-method class 
131            (ensure-generic-function reader :lambda-list '(object)) 
132            (slot-definition-name slotd)))
133       (loop
134        for writer in (slot-definition-writers slotd)
135        do (add-writer-method class 
136            (ensure-generic-function writer :lambda-list '(value object)) 
137            (slot-definition-name slotd)))))
138
139 (defmethod direct-slot-definition-class ((class container-child-class) &rest initargs)
140   (case (getf initargs :allocation)
141     (:property (find-class 'direct-child-slot-definition))
142     (t (call-next-method))))
143
144 (defmethod effective-slot-definition-class ((class container-child-class) &rest initargs)
145   (case (getf initargs :allocation)
146     (:property (find-class 'effective-child-slot-definition))
147     (t (call-next-method))))
148
149 (defmethod compute-effective-slot-definition-initargs ((class container-child-class) direct-slotds)
150   (if (eq (slot-definition-allocation (first direct-slotds)) :property)
151       (nconc 
152        (list :pname (most-specific-slot-value direct-slotds 'pname))
153        (call-next-method))
154     (call-next-method)))
155
156 (defmethod slot-readable-p ((slotd effective-child-slot-definition))
157   (declare (ignore slotd))
158   t)
159
160 (defmethod compute-slot-reader-function ((slotd effective-child-slot-definition) &optional signal-unbound-p)
161   (declare (ignore signal-unbound-p))
162   (let* ((type (slot-definition-type slotd))
163          (pname (slot-definition-pname slotd))
164          (reader (reader-function type :ref :get)))
165     #'(lambda (object)
166         (with-slots (parent child) object          
167           (with-memory (gvalue +gvalue-size+)
168             (glib::%gvalue-init gvalue (find-type-number type))
169             (%container-child-get-property parent child pname gvalue)
170             (funcall reader gvalue +gvalue-value-offset+))))))
171
172 (defmethod slot-writable-p ((slotd effective-child-slot-definition))
173   (declare (ignore slotd))
174   t)
175
176 (defmethod compute-slot-writer-function ((slotd effective-child-slot-definition))
177   (let* ((type (slot-definition-type slotd))
178          (pname (slot-definition-pname slotd))
179          (writer (writer-function type :temp t))
180          (destroy (destroy-function type :temp t)))
181     #'(lambda (value object)
182         (with-slots (parent child) object          
183           (with-memory (gvalue +gvalue-size+)
184             (glib::%gvalue-init gvalue (find-type-number type))
185             (funcall writer value gvalue +gvalue-value-offset+)
186             (%container-child-set-property parent child pname gvalue)
187             (funcall destroy gvalue +gvalue-value-offset+))
188           value))))
189
190
191 (defmethod add-reader-method ((class container-child-class) generic-function slot-name #?(sbcl>= 1 0 2)slot-documentation #?(sbcl>= 1 0 14)source-location)
192   (add-method
193    generic-function
194    (make-instance 'standard-method
195     :specializers (list (find-class 'widget))
196     :lambda-list '(widget)
197     :documentation (or #?(sbcl>= 1 0 2)slot-documentation "automatically generated reader method")
198     :function #'(lambda (args next-methods)
199                   (declare (ignore next-methods))
200                   (child-property-value (first args) slot-name)))))
201
202 (defmethod add-writer-method ((class container-child-class) generic-function slot-name #?(sbcl>= 1 0 2)slot-documentation #?(sbcl>= 1 0 14)source-location)
203   (add-method
204    generic-function
205    (make-instance 'standard-method
206     :specializers (list (find-class t) (find-class 'widget))
207     :lambda-list '(value widget)
208     :documentation (or #?(sbcl>= 1 0 2)slot-documentation "automatically generated reader method")
209     :function #'(lambda (args next-methods)
210                   (declare (ignore next-methods))
211                   (destructuring-bind (value widget) args
212                     (setf (child-property-value widget slot-name) value))))))
213
214
215 (defmethod validate-superclass ((class container-child-class) (super standard-class))
216   ;(subtypep (class-name super) 'container-child)
217   t)
218
219
220 (defclass container-child (virtual-slots-object)
221   ((parent :initarg :parent :type container)
222    (child :initarg :child :type widget)))
223
224
225 ;;;;
226
227 (defbinding %container-class-list-child-properties () pointer
228   (class pointer)
229   (n-properties unsigned-int :out))
230
231 (defun query-container-class-child-properties (type-number &optional owner-only-p)
232   (let ((class (type-class-ref type-number)))
233     (multiple-value-bind (array length)
234         (%container-class-list-child-properties class)
235       (unwind-protect
236           (let ((properties (map-c-vector 'list #'identity array 'param length)))
237             (if owner-only-p
238                 (delete-if 
239                   #'(lambda (property)
240                       (not (eql (slot-value property 'glib::owner-type) type-number)))
241                   properties)
242               properties))
243         (deallocate-memory array)))))
244
245 (defun default-container-child-name (container-class)
246   (intern (format nil "~A-CHILD" container-class)))
247
248 (defun expand-container-type (type forward-p options)
249   (let* ((class (type-from-number type))
250          (super (supertype type))
251          (child-class (default-container-child-name class)))
252     (if forward-p 
253         (expand-gobject-type type t options)
254       `(progn
255          ,(expand-gobject-type type nil options)
256          ,(let ((child-properties (query-container-class-child-properties type t)))
257             (when child-properties
258               `(defclass ,child-class (,(default-container-child-name super))
259                  ,(slot-definitions child-class child-properties nil)
260                  (:metaclass container-child-class)
261                  (:container ,class))))))))
262
263 (defun container-dependencies (type options)
264   (delete-duplicates 
265    (append
266     (gobject-dependencies type options)
267     (mapcar #'param-value-type (query-container-class-child-properties type)))))
268
269 (register-derivable-type 'container "GtkContainer" 'expand-container-type 'container-dependencies)
270
271
272 (defmacro define-callback-setter (name arg return-type &rest rest-args)
273   (let ((callback (gensym)))
274     (if arg
275         `(progn 
276            (define-callback-marshal ,callback ,return-type 
277              ,(cons arg rest-args))
278            (defbinding ,name () nil
279              ,arg
280              (,callback callback)
281              (function user-callback)
282              (user-data-destroy-callback callback)))
283       `(progn 
284          (define-callback-marshal ,callback ,return-type ,rest-args)
285          (defbinding ,name () nil
286            (,callback callback)
287            (function user-callback)
288            (user-data-destroy-callback callback))))))
289