1 ;; Common Lisp bindings for GTK+ v2.0
2 ;; Copyright (C) 2000-2002 Espen S. Johnsen <espen@users.sourceforge.net>
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.
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.
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
18 ;; $Id: gtkwidget.lisp,v 1.14 2005-01-06 21:00:51 espen Exp $
23 (defmethod shared-initialize ((widget widget) names &rest initargs &key parent)
24 (remf initargs :parent)
26 (apply #'call-next-method widget names initargs)
28 (when (slot-boundp widget 'parent)
29 (container-remove (widget-parent widget) widget))
30 (let ((parent-widget (first (mklist parent)))
31 (args (rest (mklist parent))))
32 (apply #'container-add parent-widget widget args)))))
34 (defmethod shared-initialize :after ((widget widget) names &rest initargs
35 &key show-all all-visible)
36 (declare (ignore initargs names))
37 (when (or all-visible show-all)
38 (widget-show-all widget)))
41 (defmethod slot-unbound ((class gobject-class) (object widget) slot)
43 ((and (eq slot 'child-properties) (slot-value object 'parent))
44 (with-slots (parent child-properties) object
48 (gethash (class-of parent) *container-to-child-class-mappings*)
49 :parent parent :child object))))
50 (t (call-next-method))))
52 (defmethod create-callback-function ((widget widget) function arg1)
54 #'(lambda (&rest args)
55 (if (slot-boundp widget 'parent)
56 (apply function (widget-parent widget) (rest args))
57 (signal-connect widget 'parent-set
58 #'(lambda (old-parent)
59 (declare (ignore old-parent))
60 (let ((*signal-stop-emission*
62 (warn "Ignoring emission stop in delayed signal handler"))))
63 (apply function (widget-parent widget) (rest args))))
65 ; (warn "Widget has no parent -- ignoring signal")
69 (defun child-property-value (widget slot)
70 (slot-value (widget-child-properties widget) slot))
72 (defun (setf child-property-value) (value widget slot)
73 (setf (slot-value (widget-child-properties widget) slot) value))
75 (defmacro with-child-properties (slots widget &body body)
76 `(with-slots ,slots (widget-child-properties ,widget)
80 (defmacro widget-destroyed (place)
86 (defbinding widget-destroy () nil
89 (defbinding widget-unparent () nil
92 (defbinding widget-show () nil
95 (defbinding widget-show-now () nil
98 (defbinding widget-hide () nil
101 (defbinding widget-show-all () nil
104 (defbinding widget-hide-all () nil
107 (defbinding widget-map () nil
110 (defbinding widget-unmap () nil
113 (defbinding widget-realize () nil
116 (defbinding widget-unrealize () nil
119 (defbinding widget-queue-draw () nil
122 (defbinding widget-queue-resize () nil
125 (defbinding widget-size-request () nil
127 (requisition requisition))
129 (defbinding widget-get-child-requisition () nil
131 (requisition requisition))
133 (defbinding widget-size-allocate () nil
135 (allocation allocation))
138 (defbinding widget-add-accelerator
139 (widget signal accel-group key modifiers flags) nil
141 ((name-to-string signal) string)
142 (accel-group accel-group)
143 ((gdk:keyval-from-name key) unsigned-int)
144 (modifiers gdk:modifier-type)
147 (defbinding widget-remove-accelerator
148 (widget accel-group key modifiers) nil
150 (accel-group accel-group)
151 ((gdk:keyval-from-name key) unsigned-int)
152 (modifiers gdk:modifier-type))
154 (defbinding (widget-set-accelerator-path "gtk_widget_set_accel_path") () nil
157 (accel-group accel-group))
160 (defbinding widget-event () int
164 (defbinding widget-activate () boolean
167 (defbinding widget-reparent () nil
171 (defbinding %widget-intersect () boolean
174 (intersection (or null gdk:rectangle)))
176 (defun widget-intersection (widget area)
177 (let ((intersection (make-instance 'gdk:rectangle)))
178 (when (%widget-intersect widget area intersection)
181 (defun widget-intersect-p (widget area)
182 (%widget-intersect widget area nil))
184 ;; (defbinding (widget-is-focus-p "gtk_widget_is_focus") () boolean
187 (defbinding widget-grab-focus () nil
190 (defbinding widget-grab-default () nil
193 (defbinding widget-add-events () nil
195 (events gdk:event-mask))
197 (defbinding widget-get-toplevel () widget
200 (defbinding widget-get-ancestor (widget type) widget
202 ((find-type-number type) type-number))
204 (defbinding widget-get-pointer () nil
209 (defbinding (widget-is-ancestor-p "gtk_widget_is_ancestor") () boolean
213 (defbinding widget-translate-coordinates () boolean
216 (src-x int) (src-y int)
217 (set-x int :out) (dest-y int :out))
219 (defun widget-hide-on-delete (widget)
220 "Utility function; intended to be connected to the DELETE-EVENT
221 signal on a GtkWindow. The function calls WIDGET-HIDE on its
222 argument, then returns T. If connected to DELETE-EVENT, the
223 result is that clicking the close button for a window (on the window
224 frame, top right corner usually) will hide but not destroy the
225 window. By default, GTK+ destroys windows when DELETE-EVENT is
230 (defbinding widget-ensure-style () nil
233 (defbinding widget-reset-rc-styles () nil
236 (defbinding widget-push-colormap () nil
237 (colormap gdk:colormap))
239 (defbinding widget-pop-colormap () nil)
241 (defbinding widget-set-default-colormap () nil
242 (colormap gdk:colormap))
244 (defbinding widget-get-default-style () style)
246 (defbinding widget-get-default-colormap () gdk:colormap)
248 (defbinding widget-get-default-visual () gdk:visual)
250 (defbinding widget-get-default-direction () text-direction)
252 (defbinding widget-set-default-direction () nil
253 (direction text-direction))
255 (defbinding widget-shape-combine-mask () nil
257 (shape-mask gdk:bitmap)
261 (defbinding widget-path () nil
263 (path-length int :out)
265 (reverse-path string :out))
267 (defbinding widget-class-path () nil
269 (path-length int :out)
271 (reverse-path string :out))
273 (defbinding widget-modify-style () nil
277 (defbinding widget-modify-style () rc-style
280 (defbinding (widget-modify-foreground "gtk_widget_modify_fg") () nil
285 (defbinding (widget-modify-background "gtk_widget_modify_bg") () nil
290 (defbinding widget-modify-text () nil
295 (defbinding widget-modify-base () nil
300 (defbinding widget-modify-font () nil
303 (font-desc pango:font-description))
305 (defbinding widget-create-pango-context () pango:context
308 (defbinding widget-get-pango-context () pango:context
311 (defbinding widget-create-pango-layout (widget &optional text) pango:layout
313 (text (or string null)))
315 (defbinding widget-render-icon () gdk:pixbuf
321 (defbinding widget-push-composite-child () nil)
323 (defbinding widget-pop-composite-child () nil)
325 (defbinding widget-queue-draw-area () nil
327 (x int) (y int) (width int) (height int))
329 (defbinding widget-reset-shapes () nil
332 (defbinding widget-set-double-buffered () nil
334 (double-buffered boolean))
336 (defbinding widget-set-redraw-on-allocate () nil
338 (redraw-on-allocate boolean))
340 (defbinding widget-set-scroll-adjustments () boolean
342 (hadjustment adjustment)
343 (vadjustment adjustment))
345 (defbinding widget-mnemonic-activate () boolean
347 (group-cycling boolean))
349 (defbinding widget-region-intersect () pointer ;gdk:region
351 (region pointer)) ;gdk:region))
353 (defbinding widget-send-expose () int
357 (defbinding widget-get-accessible () atk:object
360 (defbinding widget-child-focus () boolean
362 (direction direction-type))
364 (defbinding widget-child-notify () nil
366 (child-property string))
368 (defbinding widget-freeze-child-notify () nil
371 (defbinding %widget-get-size-request () nil
376 (defun widget-get-size-request (widget)
377 (multiple-value-bind (width height) (%widget-get-size-request widget)
378 (values (unless (= width -1) width) (unless (= height -1) height))))
380 (defbinding widget-set-size-request (widget width height) nil
383 ((or height -1) int))
385 (defbinding widget-thaw-child-notify () nil
389 ;;; Additional bindings and functions
391 (defbinding (widget-mapped-p "gtk_widget_mapped_p") () boolean
394 (defbinding widget-get-size-allocation () nil
399 (defbinding get-event-widget () widget
402 (defun (setf widget-cursor) (cursor-type widget)
403 (let ((cursor (make-instance 'gdk:cursor :type cursor-type)))
404 (gdk:window-set-cursor (widget-window widget) cursor)))