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

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