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