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