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