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

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