1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
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:
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
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.
23 ;; $Id: gtkobject.lisp,v 1.44 2007-09-06 14:22:19 espen Exp $
29 ;;;; Superclass for the gtk class hierarchy
31 (eval-when (:compile-toplevel :load-toplevel :execute)
32 (init-types-in-library gtk "libgtk-2.0")
34 (defclass %object (gobject)
36 (:metaclass gobject-class)
37 (:gtype |gtk_object_get_type|)))
40 (defmethod initialize-instance ((object %object) &rest initargs &key signal)
41 (declare (ignore signal))
43 (dolist (signal-definition (get-all initargs :signal))
44 (apply #'signal-connect object signal-definition)))
46 (defmethod initialize-instance :around ((object %object) &rest initargs)
47 (declare (ignore initargs))
49 ;; Add a temorary reference which will be removed when the object is
51 (funcall (reference-function '%object) (foreign-location object))
52 (%object-sink object))
54 (defbinding %object-sink () nil
57 ;;;; Main loop and event handling
59 (defbinding events-pending-p () boolean)
61 (defbinding get-current-event () gdk:event)
63 (defbinding main-do-event () nil
66 (defbinding main () nil)
68 (defbinding main-level () int)
70 (defbinding main-quit () nil)
72 (defbinding main-iteration-do (&optional (blocking t)) boolean
75 (defun main-iterate-all (&rest args)
76 (declare (ignore args))
78 while (events-pending-p)
79 do (main-iteration-do nil))
83 (define-callback fd-source-callback-marshal nil
84 ((callback-id unsigned-int) (fd unsigned-int))
85 (glib::invoke-source-callback callback-id fd))
87 (defbinding (input-add "gtk_input_add_full") (fd condition function) unsigned-int
89 (condition gdk:input-condition)
90 (fd-source-callback-marshal callback)
92 ((register-callback-function function) unsigned-long)
93 (user-data-destroy-callback callback))
96 ;;;; Metaclass for child classes
98 (defvar *container-to-child-class-mappings* (make-hash-table))
100 (eval-when (:compile-toplevel :load-toplevel :execute)
101 (defclass container-child-class (virtual-slots-class)
104 (defclass direct-child-slot-definition (direct-virtual-slot-definition)
105 ((pname :reader slot-definition-pname :initarg :pname)))
107 (defclass effective-child-slot-definition (effective-virtual-slot-definition)
108 ((pname :reader slot-definition-pname :initarg :pname))))
111 (defmethod shared-initialize ((class container-child-class) names &key container)
112 (declare (ignore names))
115 (gethash (find-class (first container)) *container-to-child-class-mappings*)
119 for slotd in (class-direct-slots class)
120 when (typep slotd 'direct-child-slot-definition)
122 for reader in (slot-definition-readers slotd)
123 do (add-reader-method class
124 (ensure-generic-function reader :lambda-list '(object))
125 (slot-definition-name slotd)))
127 for writer in (slot-definition-writers slotd)
128 do (add-writer-method class
129 (ensure-generic-function writer :lambda-list '(value object))
130 (slot-definition-name slotd)))))
132 (defmethod direct-slot-definition-class ((class container-child-class) &rest initargs)
133 (case (getf initargs :allocation)
134 (:property (find-class 'direct-child-slot-definition))
135 (t (call-next-method))))
137 (defmethod effective-slot-definition-class ((class container-child-class) &rest initargs)
138 (case (getf initargs :allocation)
139 (:property (find-class 'effective-child-slot-definition))
140 (t (call-next-method))))
142 (defmethod compute-effective-slot-definition-initargs ((class container-child-class) direct-slotds)
143 (if (eq (slot-definition-allocation (first direct-slotds)) :property)
145 (list :pname (most-specific-slot-value direct-slotds 'pname))
149 (defmethod slot-readable-p ((slotd effective-child-slot-definition))
150 (declare (ignore slotd))
153 (defmethod compute-slot-reader-function ((slotd effective-child-slot-definition) &optional signal-unbound-p)
154 (declare (ignore signal-unbound-p))
155 (let* ((type (slot-definition-type slotd))
156 (pname (slot-definition-pname slotd))
157 (reader (reader-function type :ref :get)))
159 (with-slots (parent child) object
160 (with-memory (gvalue +gvalue-size+)
161 (glib::%gvalue-init gvalue (find-type-number type))
162 (%container-child-get-property parent child pname gvalue)
163 (funcall reader gvalue +gvalue-value-offset+))))))
165 (defmethod slot-writable-p ((slotd effective-child-slot-definition))
166 (declare (ignore slotd))
169 (defmethod compute-slot-writer-function ((slotd effective-child-slot-definition))
170 (let* ((type (slot-definition-type slotd))
171 (pname (slot-definition-pname slotd))
172 (writer (writer-function type :temp t))
173 (destroy (destroy-function type :temp t)))
174 #'(lambda (value object)
175 (with-slots (parent child) object
176 (with-memory (gvalue +gvalue-size+)
177 (glib::%gvalue-init gvalue (find-type-number type))
178 (funcall writer value gvalue +gvalue-value-offset+)
179 (%container-child-set-property parent child pname gvalue)
180 (funcall destroy gvalue +gvalue-value-offset+))
184 (defmethod add-reader-method ((class container-child-class) generic-function slot-name #?(sbcl>= 1 0 2)slot-documentation)
187 (make-instance 'standard-method
188 :specializers (list (find-class 'widget))
189 :lambda-list '(widget)
190 :documentation (or #?(sbcl>= 1 0 2)slot-documentation "automatically generated reader method")
191 :function #'(lambda (args next-methods)
192 (declare (ignore next-methods))
193 (child-property-value (first args) slot-name)))))
195 (defmethod add-writer-method ((class container-child-class) generic-function slot-name #?(sbcl>= 1 0 2)slot-documentation)
198 (make-instance 'standard-method
199 :specializers (list (find-class t) (find-class 'widget))
200 :lambda-list '(value widget)
201 :documentation (or #?(sbcl>= 1 0 2)slot-documentation "automatically generated reader method")
202 :function #'(lambda (args next-methods)
203 (declare (ignore next-methods))
204 (destructuring-bind (value widget) args
205 (setf (child-property-value widget slot-name) value))))))
208 (defmethod validate-superclass ((class container-child-class) (super standard-class))
209 ;(subtypep (class-name super) 'container-child)
213 (defclass container-child (virtual-slots-object)
214 ((parent :initarg :parent :type container)
215 (child :initarg :child :type widget)))
220 (defbinding %container-class-list-child-properties () pointer
222 (n-properties unsigned-int :out))
224 (defun query-container-class-child-properties (type-number)
225 (let ((class (type-class-ref type-number)))
226 (multiple-value-bind (array length)
227 (%container-class-list-child-properties class)
229 (map-c-vector 'list #'identity array 'param length)
230 (deallocate-memory array)))))
232 (defun default-container-child-name (container-class)
233 (intern (format nil "~A-CHILD" container-class)))
235 (defun expand-container-type (type forward-p options)
236 (let* ((class (type-from-number type))
237 (super (supertype type))
238 (child-class (default-container-child-name class)))
240 (expand-gobject-type type t options)
242 ,(expand-gobject-type type nil options)
243 (defclass ,child-class (,(default-container-child-name super))
244 ,(slot-definitions child-class
245 (query-container-class-child-properties type) nil)
246 (:metaclass container-child-class)
247 (:container ,class))))))
249 (defun container-child-class (container-class)
250 (gethash container-class *container-to-child-class-mappings*))
252 (defun container-dependencies (type options)
255 (gobject-dependencies type options)
256 (mapcar #'param-value-type (query-container-class-child-properties type)))))
258 (register-derivable-type 'container "GtkContainer" 'expand-container-type 'container-dependencies)
261 (defmacro define-callback-setter (name arg return-type &rest rest-args)
262 (let ((callback (gensym)))
265 (define-callback-marshal ,callback ,return-type
266 ,(cons arg rest-args))
267 (defbinding ,name () nil
270 (function user-callback)
271 (user-data-destroy-callback callback)))
273 (define-callback-marshal ,callback ,return-type ,rest-args)
274 (defbinding ,name () nil
276 (function user-callback)
277 (user-data-destroy-callback callback))))))