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

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 2000-2006 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.28 2007-06-20 10:20:47 espen Exp $
  24
  25 (in-package "GTK")
  26
  27 #-debug-ref-counting
  28 (defmethod print-object ((widget widget) stream)
  29   (if (and
  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))))
  35     (call-next-method)))
  36
  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
  42      #'(lambda ()
  43          (unset-user-data widget 'hidden-p))
  44      :remove t))
  45   (call-next-method))
  46
  47 (defmethod shared-initialize :after ((widget widget) names &key parent visible)
  48   (declare (ignore names))
  49   (when visible
  50     (widget-show widget))
  51   (when parent
  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))))
  56
  57 (defmethod slot-unbound ((class gobject-class) (object widget)
  58                          (slot (eql 'child-properties)))
  59   (cond
  60    ((slot-boundp object 'parent)
  61     (with-slots (parent child-properties) object
  62       (setf child-properties
  63        (make-instance
  64         (gethash (class-of parent) *container-to-child-class-mappings*)
  65         :parent parent :child object))))
  66    ((call-next-method))))
  67
  68
  69 (defparameter *widget-display-as-default-in-signal-handler-p* t)
  70
  71 (defmethod compute-signal-function ((widget widget) signal function object args)
  72   (let ((wrapper
  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)))
  83                       :remove t))))
  84            (call-next-method))))
  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))))
  91       wrapper)))
  92
  93
  94
  95 (defun child-property-value (widget slot)
  96   (slot-value (widget-child-properties widget) slot))
  97
  98 (defun (setf child-property-value) (value widget slot)
  99   (setf (slot-value (widget-child-properties widget) slot) value))
 100
 101 (defmacro with-child-properties (slots widget &body body)
 102   `(with-slots ,slots (widget-child-properties ,widget)
 103      ,@body))
 104
 105
 106 ;;; Bindings
 107
 108 (defbinding widget-destroy () nil
 109   (widget widget))
 110
 111 (defbinding widget-unparent () nil
 112   (widget widget))
 113
 114 (defbinding widget-show () nil
 115   (widget widget))
 116
 117 (defbinding widget-show-now () nil
 118   (widget widget))
 119
 120 (defbinding widget-hide () nil
 121   (widget widget))
 122
 123 (defun widget-hidden-p (widget)
 124   "Return T if WIDGET has been explicit hidden during construction."
 125   (user-data widget 'hidden-p))
 126
 127 (defbinding widget-show-all () nil
 128   (widget widget))
 129
 130 (defbinding widget-hide-all () nil
 131   (widget widget))
 132
 133 (defbinding widget-map () nil
 134   (widget widget))
 135
 136 (defbinding widget-unmap () nil
 137   (widget widget))
 138
 139 (defbinding widget-realize () nil
 140   (widget widget))
 141
 142 (defbinding widget-unrealize () nil
 143   (widget widget))
 144
 145 (defbinding widget-queue-draw () nil
 146   (widget widget))
 147
 148 (defbinding widget-queue-resize () nil
 149   (widget widget))
 150
 151 (defbinding widget-queue-resize-no-redraw () nil
 152   (widget widget))
 153
 154 (defbinding widget-size-request
 155     (widget &optional (requisition (make-instance 'requisition))) nil
 156   (widget widget)
 157   (requisition requisition :in/return))
 158
 159 (defbinding widget-get-child-requisition
 160     (widget &optional (requisition (make-instance 'requisition))) nil
 161   (widget widget)
 162   (requisition requisition :in/return))
 163
 164 (defbinding widget-size-allocate () nil
 165   (widget widget)
 166   (allocation allocation))
 167
 168 (defbinding widget-add-accelerator
 169     (widget signal accel-group key modifiers flags) nil
 170   (widget widget)
 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)
 175   (flags accel-flags))
 176
 177 (defbinding widget-remove-accelerator
 178     (widget accel-group key modifiers) nil
 179   (widget widget)
 180   (accel-group accel-group)
 181   ((gdk:keyval-from-name key) unsigned-int)
 182   (modifiers gdk:modifier-type))
 183
 184 (defbinding widget-set-accel-path () nil
 185   (widget widget)
 186   (accel-path string)
 187   (accel-group accel-group))
 188
 189 (defbinding widget-list-accel-closures () (glist pointer)
 190   (widget widget))
 191
 192 (defbinding widget-can-activate-accel-p () boolean
 193   (widget widget)
 194   (signal-id unsigned-int))
 195
 196 (defbinding widget-event () boolean
 197   (widget widget)
 198   (event gdk:event))
 199
 200 (defbinding widget-activate () boolean
 201   (widget widget))
 202
 203 (defbinding widget-reparent () nil
 204   (widget widget)
 205   (new-parent widget))
 206
 207 (defbinding %widget-intersect () boolean
 208   (widget widget)
 209   (area gdk:rectangle)
 210   (intersection (or null gdk:rectangle)))
 211
 212 (defun widget-intersection (widget area)
 213   (let ((intersection (make-instance 'gdk:rectangle)))
 214     (when (%widget-intersect widget area intersection)
 215       intersection)))
 216
 217 (defun widget-intersect-p (widget area)
 218   (%widget-intersect widget area nil))
 219
 220 (defbinding widget-grab-focus () nil
 221   (widget widget))
 222
 223 (defbinding widget-grab-default () nil
 224   (widget widget))
 225
 226 (defbinding widget-add-events () nil
 227   (widget widget)
 228   (events gdk:event-mask))
 229
 230 (defbinding widget-get-toplevel () widget
 231   (widget widget))
 232
 233 (defbinding widget-get-ancestor (widget type) widget
 234   (widget widget)
 235   ((find-type-number type) type-number))
 236
 237 (defbinding widget-get-pointer () nil
 238   (widget widget)
 239   (x int :out)
 240   (y int :out))
 241
 242 (defbinding widget-is-ancestor-p () boolean
 243   (widget widget)
 244   (ancestor widget))
 245
 246 (defbinding widget-translate-coordinates () boolean
 247   (src-widget widget)
 248   (dest-widget widget)
 249   (src-x int) (src-y int)
 250   (set-x int :out) (dest-y int :out))
 251
 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
 259 received."
 260   (widget-hide widget)
 261   t)
 262
 263 (defbinding widget-ensure-style () nil
 264   (widget widget))
 265
 266 (defbinding widget-reset-rc-styles () nil
 267   (widget widget))
 268
 269 (defbinding widget-push-colormap () nil
 270   (colormap gdk:colormap))
 271
 272 (defbinding widget-pop-colormap () nil)
 273
 274 (defbinding %widget-set-default-colormap () nil
 275   (colormap gdk:colormap))
 276
 277 (defun (setf widget-default-colormap) (colormap)
 278   (%widget-set-default-colormap colormap)
 279   colormap)
 280
 281 (defbinding (widget-default-style "gtk_widget_get_default_style") () style)
 282
 283 (defbinding (widget-default-colromap "gtk_widget_get_default_colormap")
 284     () gdk:colormap)
 285
 286 (defbinding (widget-default-visual "gtk_widget_get_default_visual")
 287     () gdk:visual)
 288
 289 (defbinding (widget-default-direction "gtk_widget_get_default_direction")
 290     () text-direction)
 291
 292 (defbinding %widget-set-default-direction () nil
 293   (direction text-direction))
 294
 295 (defun (setf widget-default-direction) (direction)
 296   (%widget-set-default-direction direction)
 297   direction)
 298
 299 (defbinding widget-shape-combine-mask () nil
 300   (widget widget)
 301   (shape-mask (or null gdk:bitmap))
 302   (x-offset int)
 303   (y-offset int))
 304
 305 (defun widget-path (widget)
 306   (let ((subpath (list (if (and
 307                             (slot-boundp widget 'name)
 308                             (not (zerop (length (widget-name widget)))))
 309                            (widget-name widget)
 310                          (type-of widget)))))
 311     (if (slot-boundp widget 'parent)
 312         (nconc (widget-path (widget-parent widget)) subpath)
 313       subpath)))
 314
 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)
 319     subpath)))
 320
 321
 322 (defun widget-path-lookup (path &optional (root (nreverse (window-list-toplevels))) (error-p t))
 323   (let ((component (first path)))
 324     (loop
 325      for widget in (mklist root)
 326      do (when (or
 327                (and
 328                 (stringp component) (slot-boundp widget 'name)
 329                 (string= component (widget-name widget)))
 330                (and
 331                 (symbolp component) (typep widget component)))
 332           (cond
 333            ((endp (rest path)) (return widget))
 334            ((typep widget 'container)
 335             (let ((descendant (widget-path-lookup (rest path) (container-children widget) nil)))
 336               (when descendant
 337                 (return descendant))))))))
 338   (when error-p
 339     (error "Widget not found: ~A" path)))
 340
 341
 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."
 345   (loop
 346    for widget in (mklist root)
 347    do (cond
 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)))
 352           (when descendant
 353             (return-from widget-find descendant))))))
 354   (when error-p
 355     (error "Widget not found: ~A" name)))
 356
 357
 358 (defbinding widget-modify-style () nil
 359   (widget widget)
 360   (style rc-style))
 361
 362 (defbinding widget-get-modifier-style () rc-style
 363   (widget widget))
 364
 365 (defbinding widget-modify-fg () nil
 366   (widget widget)
 367   (state state-type)
 368   (color gdk:color))
 369
 370 (defbinding widget-modify-bg () nil
 371   (widget widget)
 372   (state state-type)
 373   (color gdk:color))
 374
 375 (defbinding widget-modify-text () nil
 376   (widget widget)
 377   (state state-type)
 378   (color gdk:color))
 379
 380 (defbinding widget-modify-base () nil
 381   (widget widget)
 382   (state state-type)
 383   (color gdk:color))
 384
 385 (defbinding widget-modify-font (widget font-desc) nil
 386   (widget widget)
 387   ((etypecase font-desc
 388      (pango:font-description font-desc)
 389      (string (pango:font-description-from-string font-desc)))
 390    pango:font-description))
 391
 392 (defbinding widget-create-pango-context () pango:context
 393   (widget widget))
 394
 395 (defbinding widget-get-pango-context () pango:context
 396   (widget widget))
 397
 398 (defbinding widget-create-pango-layout (widget &optional text) pango:layout
 399   (widget widget)
 400   (text (or string null)))
 401
 402 (defbinding widget-render-icon (widget stock-id &optional size detail)
 403     gdk:pixbuf
 404   (widget widget)
 405   (stock-id string)
 406   ((or size -1) (or icon-size int))
 407   (detail (or null string)))
 408
 409 (defbinding widget-push-composite-child () nil)
 410
 411 (defbinding widget-pop-composite-child () nil)
 412
 413 (defbinding widget-queue-draw-area () nil
 414   (widget widget)
 415   (x int) (y int) (width int) (height int))
 416
 417 (defbinding widget-reset-shapes () nil
 418   (widget widget))
 419
 420 (defbinding widget-set-double-buffered () nil
 421   (widget widget)
 422   (double-buffered boolean))
 423
 424 ;; (defbinding widget-set-redraw-on-allocate () nil
 425 ;;   (widget widget)
 426 ;;   (redraw-on-allocate boolean))
 427
 428 (defbinding widget-set-scroll-adjustments () boolean
 429   (widget widget)
 430   (hadjustment (or null adjustment))
 431   (vadjustment (or null adjustment)))
 432
 433 (defbinding widget-mnemonic-activate () boolean
 434   (widget widget)
 435   (group-cycling boolean))
 436
 437 (defbinding widget-class-find-style-property (class name) param
 438   ((type-class-peek class) pointer)
 439   (name string))
 440
 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))
 445
 446 (defbinding widget-region-intersect () pointer ;gdk:region
 447   (widget widget)
 448   (region pointer)) ;gdk:region))
 449
 450 (defbinding widget-send-expose () boolean
 451   (widget widget)
 452   (event gdk:event))
 453
 454 (defbinding %widget-style-get-property () nil
 455   (widget widget)
 456   (name string)
 457   (value gvalue))
 458
 459 (defun style-property-value (widget style)
 460   (let* ((name (string-downcase style))
 461          (param (widget-class-find-style-property (class-of widget) name)))
 462     (if (not param)
 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)))))
 466
 467 (defbinding widget-get-accessible () atk:object
 468   (widget widget))
 469
 470 (defbinding widget-child-focus () boolean
 471   (widget widget)
 472   (direction direction-type))
 473
 474 (defbinding widget-child-notify () nil
 475   (widget widget)
 476   (child-property string))
 477
 478 (defbinding widget-freeze-child-notify () nil
 479   (widget widget))
 480
 481 (defbinding widget-get-clipboard () clipboard
 482   (widget widget)
 483   (selection int #|gdk:atom|#))
 484
 485 (defbinding widget-get-display () gdk:display
 486   (widget widget))
 487
 488 (defbinding widget-get-root-window () gdk:window
 489   (widget widget))
 490
 491 (defbinding widget-get-screen () gdk:screen
 492   (widget widget))
 493
 494 (defbinding widget-has-screen-p () boolean
 495   (widget widget))
 496
 497 (defbinding %widget-get-size-request () nil
 498   (widget widget)
 499   (width int :out)
 500   (height int :out))
 501
 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))))
 505
 506 (defbinding widget-set-size-request (widget width height) nil
 507   (widget widget)
 508   ((or width -1) int)
 509   ((or height -1) int))
 510
 511 (defbinding widget-thaw-child-notify () nil
 512   (widget widget))
 513
 514 (defbinding widget-list-mnemonic-labels () (glist widget)
 515   (widget widget))
 516
 517 (defbinding widget-add-mnemonic-label () nil
 518   (widget widget)
 519   (label widget))
 520
 521 (defbinding widget-remove-mnemonic-label () nil
 522   (widget widget)
 523   (label widget))
 524
 525
 526 ;;; Additional bindings and functions
 527
 528 (defbinding (widget-mapped-p "gtk_widget_mapped_p") () boolean
 529   (widget widget))
 530
 531 (defbinding widget-get-size-allocation () nil
 532   (widget widget)
 533   (width int :out)
 534   (height int :out))
 535
 536 (defbinding get-event-widget () widget
 537   (event gdk:event))
 538
 539 (defun (setf widget-cursor) (cursor-type widget)
 540   (warn "(SETF WIDGET-CURSOR) is deprecated, use WIDGET-SET-CURSOR instead")
 541   (widget-set-cursor widget cursor-type))
 542
 543 (defun widget-set-cursor (widget cursor &rest args)
 544   (gdk:window-set-cursor (widget-window widget)
 545    (apply #'gdk:ensure-cursor cursor args)))
 546
 547 (defbinding %widget-get-parent-window () gdk:window
 548   (widget widget))
 549
 550 (defun %widget-parent-window (widget)
 551   (when (slot-boundp widget 'parent)
 552     (%widget-get-parent-window widget)))