chiark - git - mdw - clg/blob - gtk/gtkwidget.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 2000-2002 Espen S. Johnsen <espen@users.sourceforge.net>
   3 ;;
   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.
   8 ;;
   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.
  13 ;;
  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
  17
  18 ;; $Id: gtkwidget.lisp,v 1.17 2005-02-27 15:39:18 espen Exp $
  19
  20 (in-package "GTK")
  21
  22
  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
  27      #'(lambda ()
  28          (unset-user-data widget 'hidden-p))
  29      :remove t))
  30   (call-next-method))
  31
  32 (defmethod shared-initialize :after ((widget widget) names &key parent visible)
  33   (declare (ignore names))
  34   (when visible
  35     (widget-show widget))
  36   (when parent
  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))))
  41
  42 (defmethod slot-unbound ((class gobject-class) (object widget)
  43                          (slot (eql 'child-properties)))
  44   (cond
  45    ((slot-boundp object 'parent)
  46     (with-slots (parent child-properties) object
  47       (setf child-properties
  48        (make-instance
  49         (gethash (class-of parent) *container-to-child-class-mappings*)
  50         :parent parent :child object))))
  51    ((call-next-method))))
  52
  53 (defmethod slot-boundp-using-class ((class gobject-class) (object widget) slot)
  54   (or
  55    (and
  56     (eq (slot-definition-name slot) 'child-properties)
  57     (slot-boundp object 'parent))
  58    (call-next-method)))
  59
  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*
  70                         #'(lambda ()
  71                             (warn "Ignoring emission stop in delayed signal handler"))))
  72                    (apply function (widget-parent widget) (rest args))))
  73              :remove t)
  74 ;           (warn "Widget has no parent -- ignoring signal")
  75             ))
  76     (call-next-method)))
  77
  78 (defun child-property-value (widget slot)
  79   (slot-value (widget-child-properties widget) slot))
  80
  81 (defun (setf child-property-value) (value widget slot)
  82   (setf (slot-value (widget-child-properties widget) slot) value))
  83
  84 (defmacro with-child-properties (slots widget &body body)
  85   `(with-slots ,slots (widget-child-properties ,widget)
  86      ,@body))
  87
  88
  89 ;;; Bindings
  90
  91 (defbinding widget-destroy () nil
  92   (widget widget))
  93
  94 (defbinding widget-unparent () nil
  95   (widget widget))
  96
  97 (defbinding widget-show () nil
  98   (widget widget))
  99
 100 (defbinding widget-show-now () nil
 101   (widget widget))
 102
 103 (defbinding widget-hide () nil
 104   (widget widget))
 105
 106 (defun widget-hidden-p (widget)
 107   "Return T if WIDGET has been explicit hidden during construction."
 108   (user-data widget 'hidden-p))
 109
 110 (defbinding widget-show-all () nil
 111   (widget widget))
 112
 113 (defbinding widget-hide-all () nil
 114   (widget widget))
 115
 116 (defbinding widget-map () nil
 117   (widget widget))
 118
 119 (defbinding widget-unmap () nil
 120   (widget widget))
 121
 122 (defbinding widget-realize () nil
 123   (widget widget))
 124
 125 (defbinding widget-unrealize () nil
 126   (widget widget))
 127
 128 (defbinding widget-queue-draw () nil
 129   (widget widget))
 130
 131 (defbinding widget-queue-resize () nil
 132   (widget widget))
 133
 134 (defbinding widget-queue-resize-no-redraw () nil
 135   (widget widget))
 136
 137 (defbinding widget-size-request
 138     (widget &optional (requisition (make-instance 'requisition))) nil
 139   (widget widget)
 140   (requisition requisition :return))
 141
 142 (defbinding widget-get-child-requisition
 143     (widget &optional (requisition (make-instance 'requisition))) nil
 144   (widget widget)
 145   (requisition requisition :return))
 146
 147 (defbinding widget-size-allocate () nil
 148   (widget widget)
 149   (allocation allocation))
 150
 151 (defbinding widget-add-accelerator
 152     (widget signal accel-group key modifiers flags) nil
 153   (widget widget)
 154   ((name-to-string signal) string)
 155   (accel-group accel-group)
 156   ((gdk:keyval-from-name key) unsigned-int)
 157   (modifiers gdk:modifier-type)
 158   (flags accel-flags))
 159
 160 (defbinding widget-remove-accelerator
 161     (widget accel-group key modifiers) nil
 162   (widget widget)
 163   (accel-group accel-group)
 164   ((gdk:keyval-from-name key) unsigned-int)
 165   (modifiers gdk:modifier-type))
 166
 167 (defbinding widget-set-accel-path () nil
 168   (widget widget)
 169   (accel-path string)
 170   (accel-group accel-group))
 171
 172 (defbinding widget-list-accel-closures () (glist pointer)
 173   (widget widget))
 174
 175 (defbinding widget-can-activate-accel-p () boolean
 176   (widget widget)
 177   (signal-id unsigned-int))
 178
 179 (defbinding widget-event () boolean
 180   (widget widget)
 181   (event gdk:event))
 182
 183 (defbinding widget-activate () boolean
 184   (widget widget))
 185
 186 (defbinding widget-reparent () nil
 187   (widget widget)
 188   (new-parent widget))
 189
 190 (defbinding %widget-intersect () boolean
 191   (widget widget)
 192   (area gdk:rectangle)
 193   (intersection (or null gdk:rectangle)))
 194
 195 (defun widget-intersection (widget area)
 196   (let ((intersection (make-instance 'gdk:rectangle)))
 197     (when (%widget-intersect widget area intersection)
 198       intersection)))
 199
 200 (defun widget-intersect-p (widget area)
 201   (%widget-intersect widget area nil))
 202
 203 (defbinding widget-grab-focus () nil
 204   (widget widget))
 205
 206 (defbinding widget-grab-default () nil
 207   (widget widget))
 208
 209 (defbinding widget-add-events () nil
 210   (widget widget)
 211   (events gdk:event-mask))
 212
 213 (defbinding widget-get-toplevel () widget
 214   (widget widget))
 215
 216 (defbinding widget-get-ancestor (widget type) widget
 217   (widget widget)
 218   ((find-type-number type) type-number))
 219
 220 (defbinding widget-get-pointer () nil
 221   (widget widget)
 222   (x int :out)
 223   (y int :out))
 224
 225 (defbinding widget-is-ancestor-p () boolean
 226   (widget widget)
 227   (ancestor widget))
 228
 229 (defbinding widget-translate-coordinates () boolean
 230   (src-widget widget)
 231   (dest-widget widget)
 232   (src-x int) (src-y int)
 233   (set-x int :out) (dest-y int :out))
 234
 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
 242 received."
 243   (widget-hide widget)
 244   t)
 245
 246 (defbinding widget-ensure-style () nil
 247   (widget widget))
 248
 249 (defbinding widget-reset-rc-styles () nil
 250   (widget widget))
 251
 252 (defbinding widget-push-colormap () nil
 253   (colormap gdk:colormap))
 254
 255 (defbinding widget-pop-colormap () nil)
 256
 257 (defbinding %widget-set-default-colormap () nil
 258   (colormap gdk:colormap))
 259
 260 (defun (setf widget-default-colormap) (colormap)
 261   (%widget-set-default-colormap colormap)
 262   colormap)
 263
 264 (defbinding (widget-default-style "gtk_widget_get_default_style") () style)
 265
 266 (defbinding (widget-default-colromap "gtk_widget_get_default_colormap")
 267     () gdk:colormap)
 268
 269 (defbinding (widget-default-visual "gtk_widget_get_default_visual")
 270     () gdk:visual)
 271
 272 (defbinding (widget-default-direction "gtk_widget_get_default_direction")
 273     () text-direction)
 274
 275 (defbinding %widget-set-default-direction () nil
 276   (direction text-direction))
 277
 278 (defun (setf widget-default-direction) (direction)
 279   (%widget-set-default-direction direction)
 280   direction)
 281
 282 (defbinding widget-shape-combine-mask () nil
 283   (widget widget)
 284   (shape-mask (or null gdk:bitmap))
 285   (x-offset int)
 286   (y-offset int))
 287
 288 (defbinding widget-path () nil
 289   (widget widget)
 290   (path-length int :out)
 291   (path string :out)
 292   (reverse-path string :out))
 293
 294 (defbinding widget-class-path () nil
 295   (widget widget)
 296   (path-length int :out)
 297   (path string :out)
 298   (reverse-path string :out))
 299
 300 (defbinding widget-modify-style () nil
 301   (widget widget)
 302   (style rc-style))
 303
 304 (defbinding widget-get-modifier-style () rc-style
 305   (widget widget))
 306
 307 (defbinding widget-modify-fg () nil
 308   (widget widget)
 309   (state state-type)
 310   (color gdk:color))
 311
 312 (defbinding widget-modify-bg () nil
 313   (widget widget)
 314   (state state-type)
 315   (color gdk:color))
 316
 317 (defbinding widget-modify-text () nil
 318   (widget widget)
 319   (state state-type)
 320   (color gdk:color))
 321
 322 (defbinding widget-modify-base () nil
 323   (widget widget)
 324   (state state-type)
 325   (color gdk:color))
 326
 327 (defbinding widget-modify-font () nil
 328   (widget widget)
 329   (state state-type)
 330   (font-desc pango:font-description))
 331
 332 (defbinding widget-create-pango-context () pango:context
 333   (widget widget))
 334
 335 (defbinding widget-get-pango-context () pango:context
 336   (widget widget))
 337
 338 (defbinding widget-create-pango-layout (widget &optional text) pango:layout
 339   (widget widget)
 340   (text (or string null)))
 341
 342 (defbinding widget-render-icon (widget stock-id &optional size detail)
 343     gdk:pixbuf
 344   (widget widget)
 345   (stock-id string)
 346   ((or size -1) (or icon-size int))
 347   (detail (or null string)))
 348
 349 (defbinding widget-push-composite-child () nil)
 350
 351 (defbinding widget-pop-composite-child () nil)
 352
 353 (defbinding widget-queue-draw-area () nil
 354   (widget widget)
 355   (x int) (y int) (width int) (height int))
 356
 357 (defbinding widget-reset-shapes () nil
 358   (widget widget))
 359
 360 ;; (defbinding widget-set-double-buffered () nil
 361 ;;   (widget widget)
 362 ;;   (double-buffered boolean))
 363
 364 ;; (defbinding widget-set-redraw-on-allocate () nil
 365 ;;   (widget widget)
 366 ;;   (redraw-on-allocate boolean))
 367
 368 (defbinding widget-set-scroll-adjustments () boolean
 369   (widget widget)
 370   (hadjustment (or null adjustment))
 371   (vadjustment (or null adjustment)))
 372
 373 (defbinding widget-mnemonic-activate () boolean
 374   (widget widget)
 375   (group-cycling boolean))
 376
 377 (defbinding widget-class-find-style-property (class name) param
 378   ((type-class-peek class) pointer)
 379   (name string))
 380
 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))
 385
 386 (defbinding widget-region-intersect () pointer ;gdk:region
 387   (widget widget)
 388   (region pointer)) ;gdk:region))
 389
 390 (defbinding widget-send-expose () boolean
 391   (widget widget)
 392   (event gdk:event))
 393
 394 (defbinding %widget-style-get-property () nil
 395   (widget widget)
 396   (name string)
 397   (value gvalue))
 398
 399 (defun style-property-value (widget style)
 400   (let* ((name (string-downcase style))
 401          (param (widget-class-find-style-property (class-of widget) name)))
 402     (if (not param)
 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)))))
 406
 407 (defbinding widget-get-accessible () atk:object
 408   (widget widget))
 409
 410 (defbinding widget-child-focus () boolean
 411   (widget widget)
 412   (direction direction-type))
 413
 414 (defbinding widget-child-notify () nil
 415   (widget widget)
 416   (child-property string))
 417
 418 (defbinding widget-freeze-child-notify () nil
 419   (widget widget))
 420
 421 (defbinding widget-get-clipboard () clipboard
 422   (widget widget)
 423   (selection int #|gdk:atom|#))
 424
 425 (defbinding widget-get-display () gdk:display
 426   (widget widget))
 427
 428 (defbinding widget-get-root-window () gdk:window
 429   (widget widget))
 430
 431 (defbinding widget-get-screen () gdk:screen
 432   (widget widget))
 433
 434 (defbinding widget-has-screen-p () boolean
 435   (widget widget))
 436
 437 (defbinding %widget-get-size-request () nil
 438   (widget widget)
 439   (width int :out)
 440   (height int :out))
 441
 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))))
 445
 446 (defbinding widget-set-size-request (widget width height) nil
 447   (widget widget)
 448   ((or width -1) int)
 449   ((or height -1) int))
 450
 451 (defbinding widget-thaw-child-notify () nil
 452   (widget widget))
 453
 454 (defbinding widget-list-mnemonic-labels () (glist widget)
 455   (widget widget))
 456
 457 (defbinding widget-add-mnemonic-label () nil
 458   (widget widget)
 459   (label widget))
 460
 461 (defbinding widget-remove-mnemonic-label () nil
 462   (widget widget)
 463   (label widget))
 464
 465
 466 ;;; Additional bindings and functions
 467
 468 (defbinding (widget-mapped-p "gtk_widget_mapped_p") () boolean
 469   (widget widget))
 470
 471 (defbinding widget-get-size-allocation () nil
 472   (widget widget)
 473   (width int :out)
 474   (height int :out))
 475
 476 (defbinding get-event-widget () widget
 477   (event gdk:event))
 478
 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)))
 482
 483 (defbinding %widget-get-parent-window () gdk:window
 484   (widget widget))
 485
 486 (defun %widget-parent-window (widget)
 487   (when (slot-boundp widget 'parent)
 488     (%widget-get-parent-window widget)))