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