1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 2000-2006 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: gtkwidget.lisp,v 1.29 2007-09-06 14:27:07 espen Exp $
28 (defmethod print-object ((widget widget) stream)
30 (proxy-valid-p widget)
31 (slot-boundp widget 'name) (not (zerop (length (widget-name widget)))))
32 (print-unreadable-object (widget stream :type t :identity nil)
33 (format stream "~S at 0x~X"
34 (widget-name widget) (pointer-address (foreign-location widget))))
37 (defmethod shared-initialize ((widget widget) names &key (visible nil visible-p))
38 (declare (ignore names))
39 (when (and visible-p (not visible)) ; widget explicit set as not visible
40 (setf (user-data widget 'hidden-p) t)
41 (signal-connect widget 'show
43 (unset-user-data widget 'hidden-p))
47 (defmethod shared-initialize :after ((widget widget) names &key parent visible)
48 (declare (ignore names))
52 (when (slot-boundp widget 'parent)
53 (container-remove (widget-parent widget) widget))
54 (destructuring-bind (parent &rest args) (mklist parent)
55 (apply #'container-add parent widget args))))
57 (defmethod slot-unbound ((class gobject-class) (object widget)
58 (slot (eql 'child-properties)))
60 ((slot-boundp object 'parent)
61 (with-slots (parent child-properties) object
62 (setf child-properties
64 (gethash (class-of parent) *container-to-child-class-mappings*)
65 :parent parent :child object))))
66 ((call-next-method))))
69 (defparameter *widget-display-as-default-in-signal-handler-p* t)
71 (defmethod compute-signal-function ((widget widget) signal function object args)
73 (if (eq object :parent)
74 #'(lambda (&rest emission-args)
75 (let ((all-args (nconc (rest emission-args) args)))
76 (if (slot-boundp widget 'parent)
77 (apply function (widget-parent widget) all-args)
78 ;; Delay until parent is set
79 (signal-connect widget 'parent-set
80 #'(lambda (old-parent)
81 (declare (ignore old-parent))
82 (apply #'signal-emit widget signal (rest emission-args)))
85 (if *widget-display-as-default-in-signal-handler-p*
86 #'(lambda (&rest args)
87 (let ((display (when (slot-boundp widget 'window)
88 (gdk:drawable-display (widget-window widget)))))
89 (gdk:with-default-display (display)
90 (apply wrapper args))))
95 (defun child-property-value (widget slot)
96 (slot-value (widget-child-properties widget) slot))
98 (defun (setf child-property-value) (value widget slot)
99 (setf (slot-value (widget-child-properties widget) slot) value))
101 (defmacro with-child-properties (slots widget &body body)
102 `(with-slots ,slots (widget-child-properties ,widget)
108 (defbinding widget-destroy () nil
111 (defbinding widget-unparent () nil
114 (defbinding widget-show () nil
117 (defbinding widget-show-now () nil
120 (defbinding widget-hide () nil
123 (defun widget-hidden-p (widget)
124 "Return T if WIDGET has been explicit hidden during construction."
125 (user-data widget 'hidden-p))
127 (defbinding widget-show-all () nil
130 (defbinding widget-hide-all () nil
133 (defbinding widget-map () nil
136 (defbinding widget-unmap () nil
139 (defbinding widget-realize () nil
142 (defbinding widget-unrealize () nil
145 (defbinding widget-queue-draw () nil
148 (defbinding widget-queue-resize () nil
151 (defbinding widget-queue-resize-no-redraw () nil
154 (defbinding widget-size-request
155 (widget &optional (requisition (make-instance 'requisition))) nil
157 (requisition requisition :in/return))
159 (defbinding widget-get-child-requisition
160 (widget &optional (requisition (make-instance 'requisition))) nil
162 (requisition requisition :in/return))
164 (defbinding widget-size-allocate () nil
166 (allocation allocation))
168 (defbinding widget-add-accelerator
169 (widget signal accel-group key modifiers flags) nil
171 ((signal-name-to-string signal) string)
172 (accel-group accel-group)
173 ((gdk:keyval-from-name key) unsigned-int)
174 (modifiers gdk:modifier-type)
177 (defbinding widget-remove-accelerator
178 (widget accel-group key modifiers) nil
180 (accel-group accel-group)
181 ((gdk:keyval-from-name key) unsigned-int)
182 (modifiers gdk:modifier-type))
184 (defbinding widget-set-accel-path () nil
187 (accel-group accel-group))
189 (defbinding widget-list-accel-closures () (glist pointer)
192 (defbinding widget-can-activate-accel-p () boolean
194 (signal-id unsigned-int))
196 (defbinding widget-event () boolean
200 (defbinding widget-activate () boolean
203 (defbinding widget-reparent () nil
207 (defbinding %widget-intersect () boolean
210 (intersection (or null gdk:rectangle)))
212 (defun widget-intersection (widget area)
213 (let ((intersection (make-instance 'gdk:rectangle)))
214 (when (%widget-intersect widget area intersection)
217 (defun widget-intersect-p (widget area)
218 (%widget-intersect widget area nil))
220 (defbinding widget-grab-focus () nil
223 (defbinding widget-grab-default () nil
226 (defbinding widget-add-events () nil
228 (events gdk:event-mask))
230 (defbinding widget-get-toplevel () widget
233 (defbinding widget-get-ancestor (widget type) widget
235 ((find-type-number type) type-number))
237 (defbinding widget-get-pointer () nil
242 (defbinding widget-is-ancestor-p () boolean
246 (defbinding widget-translate-coordinates () boolean
249 (src-x int) (src-y int)
250 (set-x int :out) (dest-y int :out))
252 (defun widget-hide-on-delete (widget)
253 "Utility function; intended to be connected to the DELETE-EVENT
254 signal on a WINDOW. The function calls WIDGET-HIDE on its
255 argument, then returns T. If connected to DELETE-EVENT, the
256 result is that clicking the close button for a window (on the window
257 frame, top right corner usually) will hide but not destroy the
258 window. By default, GTK+ destroys windows when DELETE-EVENT is
263 (defbinding widget-ensure-style () nil
266 (defbinding widget-reset-rc-styles () nil
269 (defbinding widget-push-colormap () nil
270 (colormap gdk:colormap))
272 (defbinding widget-pop-colormap () nil)
274 (defbinding %widget-set-default-colormap () nil
275 (colormap gdk:colormap))
277 (defun (setf widget-default-colormap) (colormap)
278 (%widget-set-default-colormap colormap)
281 (defbinding (widget-default-style "gtk_widget_get_default_style") () style)
283 (defbinding (widget-default-colromap "gtk_widget_get_default_colormap")
286 (defbinding (widget-default-visual "gtk_widget_get_default_visual")
289 (defbinding (widget-default-direction "gtk_widget_get_default_direction")
292 (defbinding %widget-set-default-direction () nil
293 (direction text-direction))
295 (defun (setf widget-default-direction) (direction)
296 (%widget-set-default-direction direction)
299 (defbinding widget-shape-combine-mask () nil
301 (shape-mask (or null gdk:bitmap))
305 (defun widget-path (widget)
306 (let ((subpath (list (if (and
307 (slot-boundp widget 'name)
308 (not (zerop (length (widget-name widget)))))
311 (if (slot-boundp widget 'parent)
312 (nconc (widget-path (widget-parent widget)) subpath)
315 (defun widget-class-path (widget)
316 (let ((subpath (list (type-of widget))))
317 (if (slot-boundp widget 'parent)
318 (nconc (widget-class-path (widget-parent widget)) subpath)
322 (defun widget-path-lookup (path &optional (root (nreverse (window-list-toplevels))) (error-p t))
323 (let ((component (first path)))
325 for widget in (mklist root)
328 (stringp component) (slot-boundp widget 'name)
329 (string= component (widget-name widget)))
331 (symbolp component) (typep widget component)))
333 ((endp (rest path)) (return widget))
334 ((typep widget 'container)
335 (let ((descendant (widget-path-lookup (rest path) (container-children widget) nil)))
337 (return descendant))))))))
339 (error "Widget not found: ~A" path)))
342 (defun widget-find (name &optional (root (nreverse (window-list-toplevels))) (error-p t))
343 "Search for a widget with the given name. ROOT should be a container
344 widget or a list of containers."
346 for widget in (mklist root)
348 ((and (slot-boundp widget 'name) (string= name (widget-name widget)))
349 (return-from widget-find widget))
350 ((typep widget 'container)
351 (let ((descendant (widget-find name (container-children widget) nil)))
353 (return-from widget-find descendant))))))
355 (error "Widget not found: ~A" name)))
358 (defbinding widget-modify-style () nil
362 (defbinding widget-get-modifier-style () rc-style
365 (defbinding widget-modify-fg () nil
370 (defbinding widget-modify-bg () nil
375 (defbinding widget-modify-text () nil
380 (defbinding widget-modify-base () nil
385 (defbinding widget-modify-font (widget font-desc) nil
387 ((etypecase font-desc
388 (pango:font-description font-desc)
389 (string (pango:font-description-from-string font-desc)))
390 pango:font-description))
392 (defbinding widget-create-pango-context () pango:context
395 (defbinding widget-get-pango-context () pango:context
398 (defbinding widget-create-pango-layout (widget &optional text) pango:layout
400 (text (or string null)))
402 (defbinding widget-render-icon (widget stock-id &optional size detail)
406 ((or size -1) (or icon-size int))
407 (detail (or null string)))
409 (defbinding widget-push-composite-child () nil)
411 (defbinding widget-pop-composite-child () nil)
413 (defbinding widget-queue-draw-area () nil
415 (x int) (y int) (width int) (height int))
417 (defbinding widget-reset-shapes () nil
420 (defbinding widget-set-double-buffered () nil
422 (double-buffered boolean))
424 ;; (defbinding widget-set-redraw-on-allocate () nil
426 ;; (redraw-on-allocate boolean))
428 (defbinding widget-set-scroll-adjustments () boolean
430 (hadjustment (or null adjustment))
431 (vadjustment (or null adjustment)))
433 (defbinding widget-mnemonic-activate () boolean
435 (group-cycling boolean))
437 (defbinding widget-class-find-style-property (class name) param
438 ((type-class-peek class) pointer)
441 (defbinding widget-class-list-style-properties (class)
442 (vector (copy-of param) n-properties)
443 ((type-class-peek class) pointer)
444 (n-properties unsigned-int :out))
446 (defbinding widget-region-intersect () pointer ;gdk:region
448 (region pointer)) ;gdk:region))
450 (defbinding widget-send-expose () boolean
454 (defbinding %widget-style-get-property () nil
459 (defun style-property-value (widget style)
460 (let* ((name (string-downcase style))
461 (param (widget-class-find-style-property (class-of widget) name)))
463 (error "~A has no such style property: ~A" widget style)
464 (with-gvalue (gvalue (param-value-type param))
465 (%widget-style-get-property widget (string-downcase style) gvalue)))))
467 (defbinding widget-get-accessible () atk:object
470 (defbinding widget-child-focus () boolean
472 (direction direction-type))
474 (defbinding widget-child-notify () nil
476 (child-property string))
478 (defbinding widget-freeze-child-notify () nil
481 (defbinding widget-get-clipboard () clipboard
483 (selection int #|gdk:atom|#))
485 (defbinding widget-get-display () gdk:display
488 (defbinding widget-get-root-window () gdk:window
491 (defbinding widget-get-screen () gdk:screen
494 (defbinding widget-has-screen-p () boolean
497 (defbinding %widget-get-size-request () nil
502 (defun widget-get-size-request (widget)
503 (multiple-value-bind (width height) (%widget-get-size-request widget)
504 (values (unless (= width -1) width) (unless (= height -1) height))))
506 (defbinding widget-set-size-request (widget width height) nil
509 ((or height -1) int))
511 (defbinding widget-thaw-child-notify () nil
514 (defbinding widget-list-mnemonic-labels () (glist widget)
517 (defbinding widget-add-mnemonic-label () nil
521 (defbinding widget-remove-mnemonic-label () nil
526 ;;; Additional bindings and functions
528 (defbinding %widget-flags () int
531 (defun widget-flags (widget)
532 (let ((flags (%widget-flags widget)))
534 (int-to-object-flags flags)
535 (int-to-widget-flags flags))))
537 (defun widget-mapped-p (widget)
538 (find :mapped (widget-flags widget)))
540 (defun widget-realized-p (widget)
541 (find :realized (widget-flags widget)))
543 (defbinding widget-get-size-allocation () nil
548 (defbinding get-event-widget () widget
551 (defun (setf widget-cursor) (cursor-type widget)
552 (warn "(SETF WIDGET-CURSOR) is deprecated, use WIDGET-SET-CURSOR instead")
553 (widget-set-cursor widget cursor-type))
555 (defun widget-set-cursor (widget cursor &rest args)
556 (gdk:window-set-cursor (widget-window widget)
557 (apply #'gdk:ensure-cursor cursor args)))
559 (defbinding %widget-get-parent-window () gdk:window
562 (defun %widget-parent-window (widget)
563 (when (slot-boundp widget 'parent)
564 (%widget-get-parent-window widget)))