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.17 2005/02/27 15:39:18 espen Exp $
23 (defmethod shared-initialize ((widget widget) names &key (visible nil visible-p))
24 (when (and visible-p (not visible)) ; widget explicit set as not visible
25 (setf (user-data widget 'hidden-p) t)
26 (signal-connect widget 'show
28 (unset-user-data widget 'hidden-p))
32 (defmethod shared-initialize :after ((widget widget) names &key parent visible)
33 (declare (ignore names))
37 (when (slot-boundp widget 'parent)
38 (container-remove (widget-parent widget) widget))
39 (destructuring-bind (parent &rest args) (mklist parent)
40 (apply #'container-add parent widget args))))
42 (defmethod slot-unbound ((class gobject-class) (object widget)
43 (slot (eql 'child-properties)))
45 ((slot-boundp object 'parent)
46 (with-slots (parent child-properties) object
47 (setf child-properties
49 (gethash (class-of parent) *container-to-child-class-mappings*)
50 :parent parent :child object))))
51 ((call-next-method))))
53 (defmethod slot-boundp-using-class ((class gobject-class) (object widget) slot)
56 (eq (slot-definition-name slot) 'child-properties)
57 (slot-boundp object 'parent))
60 (defmethod compute-signal-function ((widget widget) signal function object)
61 (if (eq object :parent)
62 #'(lambda (&rest args)
63 (if (slot-boundp widget 'parent)
64 (apply function (widget-parent widget) (rest args))
65 ;; Delay until parent is set
66 (signal-connect widget 'parent-set
67 #'(lambda (old-parent)
68 (declare (ignore old-parent))
69 (let ((*signal-stop-emission*
71 (warn "Ignoring emission stop in delayed signal handler"))))
72 (apply function (widget-parent widget) (rest args))))
74 ; (warn "Widget has no parent -- ignoring signal")
78 (defun child-property-value (widget slot)
79 (slot-value (widget-child-properties widget) slot))
81 (defun (setf child-property-value) (value widget slot)
82 (setf (slot-value (widget-child-properties widget) slot) value))
84 (defmacro with-child-properties (slots widget &body body)
85 `(with-slots ,slots (widget-child-properties ,widget)
91 (defbinding widget-destroy () nil
94 (defbinding widget-unparent () nil
97 (defbinding widget-show () nil
100 (defbinding widget-show-now () nil
103 (defbinding widget-hide () nil
106 (defun widget-hidden-p (widget)
107 "Return T if WIDGET has been explicit hidden during construction."
108 (user-data widget 'hidden-p))
110 (defbinding widget-show-all () nil
113 (defbinding widget-hide-all () nil
116 (defbinding widget-map () nil
119 (defbinding widget-unmap () nil
122 (defbinding widget-realize () nil
125 (defbinding widget-unrealize () nil
128 (defbinding widget-queue-draw () nil
131 (defbinding widget-queue-resize () nil
134 (defbinding widget-queue-resize-no-redraw () nil
137 (defbinding widget-size-request
138 (widget &optional (requisition (make-instance 'requisition))) nil
140 (requisition requisition :return))
142 (defbinding widget-get-child-requisition
143 (widget &optional (requisition (make-instance 'requisition))) nil
145 (requisition requisition :return))
147 (defbinding widget-size-allocate () nil
149 (allocation allocation))
151 (defbinding widget-add-accelerator
152 (widget signal accel-group key modifiers flags) nil
154 ((name-to-string signal) string)
155 (accel-group accel-group)
156 ((gdk:keyval-from-name key) unsigned-int)
157 (modifiers gdk:modifier-type)
160 (defbinding widget-remove-accelerator
161 (widget accel-group key modifiers) nil
163 (accel-group accel-group)
164 ((gdk:keyval-from-name key) unsigned-int)
165 (modifiers gdk:modifier-type))
167 (defbinding widget-set-accel-path () nil
170 (accel-group accel-group))
172 (defbinding widget-list-accel-closures () (glist pointer)
175 (defbinding widget-can-activate-accel-p () boolean
177 (signal-id unsigned-int))
179 (defbinding widget-event () boolean
183 (defbinding widget-activate () boolean
186 (defbinding widget-reparent () nil
190 (defbinding %widget-intersect () boolean
193 (intersection (or null gdk:rectangle)))
195 (defun widget-intersection (widget area)
196 (let ((intersection (make-instance 'gdk:rectangle)))
197 (when (%widget-intersect widget area intersection)
200 (defun widget-intersect-p (widget area)
201 (%widget-intersect widget area nil))
203 (defbinding widget-grab-focus () nil
206 (defbinding widget-grab-default () nil
209 (defbinding widget-add-events () nil
211 (events gdk:event-mask))
213 (defbinding widget-get-toplevel () widget
216 (defbinding widget-get-ancestor (widget type) widget
218 ((find-type-number type) type-number))
220 (defbinding widget-get-pointer () nil
225 (defbinding widget-is-ancestor-p () boolean
229 (defbinding widget-translate-coordinates () boolean
232 (src-x int) (src-y int)
233 (set-x int :out) (dest-y int :out))
235 (defun widget-hide-on-delete (widget)
236 "Utility function; intended to be connected to the DELETE-EVENT
237 signal on a WINDOW. The function calls WIDGET-HIDE on its
238 argument, then returns T. If connected to DELETE-EVENT, the
239 result is that clicking the close button for a window (on the window
240 frame, top right corner usually) will hide but not destroy the
241 window. By default, GTK+ destroys windows when DELETE-EVENT is
246 (defbinding widget-ensure-style () nil
249 (defbinding widget-reset-rc-styles () nil
252 (defbinding widget-push-colormap () nil
253 (colormap gdk:colormap))
255 (defbinding widget-pop-colormap () nil)
257 (defbinding %widget-set-default-colormap () nil
258 (colormap gdk:colormap))
260 (defun (setf widget-default-colormap) (colormap)
261 (%widget-set-default-colormap colormap)
264 (defbinding (widget-default-style "gtk_widget_get_default_style") () style)
266 (defbinding (widget-default-colromap "gtk_widget_get_default_colormap")
269 (defbinding (widget-default-visual "gtk_widget_get_default_visual")
272 (defbinding (widget-default-direction "gtk_widget_get_default_direction")
275 (defbinding %widget-set-default-direction () nil
276 (direction text-direction))
278 (defun (setf widget-default-direction) (direction)
279 (%widget-set-default-direction direction)
282 (defbinding widget-shape-combine-mask () nil
284 (shape-mask (or null gdk:bitmap))
288 (defbinding widget-path () nil
290 (path-length int :out)
292 (reverse-path string :out))
294 (defbinding widget-class-path () nil
296 (path-length int :out)
298 (reverse-path string :out))
300 (defbinding widget-modify-style () nil
304 (defbinding widget-get-modifier-style () rc-style
307 (defbinding widget-modify-fg () nil
312 (defbinding widget-modify-bg () nil
317 (defbinding widget-modify-text () nil
322 (defbinding widget-modify-base () nil
327 (defbinding widget-modify-font () nil
330 (font-desc pango:font-description))
332 (defbinding widget-create-pango-context () pango:context
335 (defbinding widget-get-pango-context () pango:context
338 (defbinding widget-create-pango-layout (widget &optional text) pango:layout
340 (text (or string null)))
342 (defbinding widget-render-icon (widget stock-id &optional size detail)
346 ((or size -1) (or icon-size int))
347 (detail (or null string)))
349 (defbinding widget-push-composite-child () nil)
351 (defbinding widget-pop-composite-child () nil)
353 (defbinding widget-queue-draw-area () nil
355 (x int) (y int) (width int) (height int))
357 (defbinding widget-reset-shapes () nil
360 ;; (defbinding widget-set-double-buffered () nil
362 ;; (double-buffered boolean))
364 ;; (defbinding widget-set-redraw-on-allocate () nil
366 ;; (redraw-on-allocate boolean))
368 (defbinding widget-set-scroll-adjustments () boolean
370 (hadjustment (or null adjustment))
371 (vadjustment (or null adjustment)))
373 (defbinding widget-mnemonic-activate () boolean
375 (group-cycling boolean))
377 (defbinding widget-class-find-style-property (class name) param
378 ((type-class-peek class) pointer)
381 (defbinding widget-class-list-style-properties (class)
382 (vector (copy-of param) n-properties)
383 ((type-class-peek class) pointer)
384 (n-properties unsigned-int :out))
386 (defbinding widget-region-intersect () pointer ;gdk:region
388 (region pointer)) ;gdk:region))
390 (defbinding widget-send-expose () boolean
394 (defbinding %widget-style-get-property () nil
399 (defun style-property-value (widget style)
400 (let* ((name (string-downcase style))
401 (param (widget-class-find-style-property (class-of widget) name)))
403 (error "~A has no such style property: ~A" widget style)
404 (with-gvalue (gvalue (param-value-type param))
405 (%widget-style-get-property widget (string-downcase style) gvalue)))))
407 (defbinding widget-get-accessible () atk:object
410 (defbinding widget-child-focus () boolean
412 (direction direction-type))
414 (defbinding widget-child-notify () nil
416 (child-property string))
418 (defbinding widget-freeze-child-notify () nil
421 (defbinding widget-get-clipboard () clipboard
423 (selection int #|gdk:atom|#))
425 (defbinding widget-get-display () gdk:display
428 (defbinding widget-get-root-window () gdk:window
431 (defbinding widget-get-screen () gdk:screen
434 (defbinding widget-has-screen-p () boolean
437 (defbinding %widget-get-size-request () nil
442 (defun widget-get-size-request (widget)
443 (multiple-value-bind (width height) (%widget-get-size-request widget)
444 (values (unless (= width -1) width) (unless (= height -1) height))))
446 (defbinding widget-set-size-request (widget width height) nil
449 ((or height -1) int))
451 (defbinding widget-thaw-child-notify () nil
454 (defbinding widget-list-mnemonic-labels () (glist widget)
457 (defbinding widget-add-mnemonic-label () nil
461 (defbinding widget-remove-mnemonic-label () nil
466 ;;; Additional bindings and functions
468 (defbinding (widget-mapped-p "gtk_widget_mapped_p") () boolean
471 (defbinding widget-get-size-allocation () nil
476 (defbinding get-event-widget () widget
479 (defun (setf widget-cursor) (cursor-type widget)
480 (let ((cursor (make-instance 'gdk:cursor :type cursor-type)))
481 (gdk:window-set-cursor (widget-window widget) cursor)))
483 (defbinding %widget-get-parent-window () gdk:window
486 (defun %widget-parent-window (widget)
487 (when (slot-boundp widget 'parent)
488 (%widget-get-parent-window widget)))