mdw@git.distorted.org.uk Git - 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.14 2005-01-06 21:00:51 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
  41 (defmethod slot-unbound ((class gobject-class) (object widget) slot)
  42   (cond
  43    ((and (eq slot 'child-properties) (slot-value object 'parent))
  44     (with-slots (parent child-properties) object
  45       (setf
  46        child-properties
  47        (make-instance
  48         (gethash (class-of parent) *container-to-child-class-mappings*)
  49         :parent parent :child object))))
  50    (t (call-next-method))))
  51
  52 (defmethod create-callback-function ((widget widget) function arg1)
  53   (if (eq arg1 :parent)
  54       #'(lambda (&rest args)
  55           (if (slot-boundp widget 'parent)
  56               (apply function (widget-parent widget) (rest args))
  57             (signal-connect widget 'parent-set
  58              #'(lambda (old-parent)
  59                  (declare (ignore old-parent))
  60                  (let ((*signal-stop-emission*
  61                         #'(lambda ()
  62                             (warn "Ignoring emission stop in delayed signal handler"))))
  63                    (apply function (widget-parent widget) (rest args))))
  64              :remove t)
  65 ;           (warn "Widget has no parent -- ignoring signal")
  66             ))
  67     (call-next-method)))
  68
  69 (defun child-property-value (widget slot)
  70   (slot-value (widget-child-properties widget) slot))
  71
  72 (defun (setf child-property-value) (value widget slot)
  73   (setf (slot-value (widget-child-properties widget) slot) value))
  74
  75 (defmacro with-child-properties (slots widget &body body)
  76   `(with-slots ,slots (widget-child-properties ,widget)
  77      ,@body))
  78
  79
  80 (defmacro widget-destroyed (place)
  81   `(setf ,place nil))
  82
  83
  84 ;;; Bindings
  85
  86 (defbinding widget-destroy () nil
  87   (widget widget))
  88
  89 (defbinding widget-unparent () nil
  90   (widget widget))
  91
  92 (defbinding widget-show () nil
  93   (widget widget))
  94
  95 (defbinding widget-show-now () nil
  96   (widget widget))
  97
  98 (defbinding widget-hide () nil
  99   (widget widget))
 100
 101 (defbinding widget-show-all () nil
 102   (widget widget))
 103
 104 (defbinding widget-hide-all () nil
 105   (widget widget))
 106
 107 (defbinding widget-map () nil
 108   (widget widget))
 109
 110 (defbinding widget-unmap () nil
 111   (widget widget))
 112
 113 (defbinding widget-realize () nil
 114   (widget widget))
 115
 116 (defbinding widget-unrealize () nil
 117   (widget widget))
 118
 119 (defbinding widget-queue-draw () nil
 120   (widget widget))
 121
 122 (defbinding widget-queue-resize () nil
 123   (widget widget))
 124
 125 (defbinding widget-size-request () nil
 126   (widget widget)
 127   (requisition requisition))
 128
 129 (defbinding widget-get-child-requisition () nil
 130   (widget widget)
 131   (requisition requisition))
 132
 133 (defbinding widget-size-allocate () nil
 134   (widget widget)
 135   (allocation allocation))
 136
 137
 138 (defbinding widget-add-accelerator
 139     (widget signal accel-group key modifiers flags) nil
 140   (widget widget)
 141   ((name-to-string signal) string)
 142   (accel-group accel-group)
 143   ((gdk:keyval-from-name key) unsigned-int)
 144   (modifiers gdk:modifier-type)
 145   (flags accel-flags))
 146
 147 (defbinding widget-remove-accelerator
 148     (widget accel-group key modifiers) nil
 149   (widget widget)
 150   (accel-group accel-group)
 151   ((gdk:keyval-from-name key) unsigned-int)
 152   (modifiers gdk:modifier-type))
 153
 154 (defbinding (widget-set-accelerator-path "gtk_widget_set_accel_path") () nil
 155   (widget widget)
 156   (accel-path string)
 157   (accel-group accel-group))
 158
 159
 160 (defbinding widget-event () int
 161   (widget widget)
 162   (event gdk:event))
 163
 164 (defbinding widget-activate () boolean
 165   (widget widget))
 166
 167 (defbinding widget-reparent () nil
 168   (widget widget)
 169   (new-parent widget))
 170
 171 (defbinding %widget-intersect () boolean
 172   (widget widget)
 173   (area gdk:rectangle)
 174   (intersection (or null gdk:rectangle)))
 175
 176 (defun widget-intersection (widget area)
 177   (let ((intersection (make-instance 'gdk:rectangle)))
 178     (when (%widget-intersect widget area intersection)
 179       intersection)))
 180
 181 (defun widget-intersect-p (widget area)
 182   (%widget-intersect widget area nil))
 183
 184 ;; (defbinding (widget-is-focus-p "gtk_widget_is_focus") () boolean
 185 ;;   (widget widget))
 186
 187 (defbinding widget-grab-focus () nil
 188   (widget widget))
 189
 190 (defbinding widget-grab-default () nil
 191   (widget widget))
 192
 193 (defbinding widget-add-events () nil
 194   (widget widget)
 195   (events gdk:event-mask))
 196
 197 (defbinding widget-get-toplevel () widget
 198   (widget widget))
 199
 200 (defbinding widget-get-ancestor (widget type) widget
 201   (widget widget)
 202   ((find-type-number type) type-number))
 203
 204 (defbinding widget-get-pointer () nil
 205   (widget widget)
 206   (x int :out)
 207   (y int :out))
 208
 209 (defbinding (widget-is-ancestor-p "gtk_widget_is_ancestor") () boolean
 210   (widget widget)
 211   (ancestor widget))
 212
 213 (defbinding widget-translate-coordinates () boolean
 214   (src-widget widget)
 215   (dest-widget widget)
 216   (src-x int) (src-y int)
 217   (set-x int :out) (dest-y int :out))
 218
 219 (defun widget-hide-on-delete (widget)
 220   "Utility function; intended to be connected to the DELETE-EVENT
 221 signal on a GtkWindow. The function calls WIDGET-HIDE on its
 222 argument, then returns T. If connected to DELETE-EVENT, the
 223 result is that clicking the close button for a window (on the window
 224 frame, top right corner usually) will hide but not destroy the
 225 window. By default, GTK+ destroys windows when DELETE-EVENT is
 226 received."
 227   (widget-hide widget)
 228   t)
 229
 230 (defbinding widget-ensure-style () nil
 231   (widget widget))
 232
 233 (defbinding widget-reset-rc-styles () nil
 234   (widget widget))
 235
 236 (defbinding widget-push-colormap () nil
 237   (colormap gdk:colormap))
 238
 239 (defbinding widget-pop-colormap () nil)
 240
 241 (defbinding widget-set-default-colormap () nil
 242   (colormap gdk:colormap))
 243
 244 (defbinding widget-get-default-style () style)
 245
 246 (defbinding widget-get-default-colormap () gdk:colormap)
 247
 248 (defbinding widget-get-default-visual () gdk:visual)
 249
 250 (defbinding widget-get-default-direction () text-direction)
 251
 252 (defbinding widget-set-default-direction () nil
 253   (direction  text-direction))
 254
 255 (defbinding widget-shape-combine-mask () nil
 256   (widget widget)
 257   (shape-mask gdk:bitmap)
 258   (x-offset int)
 259   (y-offset int))
 260
 261 (defbinding widget-path () nil
 262   (widget widget)
 263   (path-length int :out)
 264   (path string :out)
 265   (reverse-path string :out))
 266
 267 (defbinding widget-class-path () nil
 268   (widget widget)
 269   (path-length int :out)
 270   (path string :out)
 271   (reverse-path string :out))
 272
 273 (defbinding widget-modify-style () nil
 274   (widget widget)
 275   (style rc-style))
 276
 277 (defbinding widget-modify-style () rc-style
 278   (widget widget))
 279
 280 (defbinding (widget-modify-foreground "gtk_widget_modify_fg") () nil
 281   (widget widget)
 282   (state state-type)
 283   (color gdk:color))
 284
 285 (defbinding (widget-modify-background "gtk_widget_modify_bg") () nil
 286   (widget widget)
 287   (state state-type)
 288   (color gdk:color))
 289
 290 (defbinding widget-modify-text () nil
 291   (widget widget)
 292   (state state-type)
 293   (color gdk:color))
 294
 295 (defbinding widget-modify-base () nil
 296   (widget widget)
 297   (state state-type)
 298   (color gdk:color))
 299
 300 (defbinding widget-modify-font () nil
 301   (widget widget)
 302   (state state-type)
 303   (font-desc pango:font-description))
 304
 305 (defbinding widget-create-pango-context () pango:context
 306   (widget widget))
 307
 308 (defbinding widget-get-pango-context () pango:context
 309   (widget widget))
 310
 311 (defbinding widget-create-pango-layout (widget &optional text) pango:layout
 312   (widget widget)
 313   (text (or string null)))
 314
 315 (defbinding widget-render-icon () gdk:pixbuf
 316   (widget widget)
 317   (stock-id string)
 318   (size icon-size)
 319   (detail string))
 320
 321 (defbinding widget-push-composite-child () nil)
 322
 323 (defbinding widget-pop-composite-child () nil)
 324
 325 (defbinding widget-queue-draw-area () nil
 326   (widget widget)
 327   (x int) (y int) (width int) (height int))
 328
 329 (defbinding widget-reset-shapes () nil
 330   (widget widget))
 331
 332 (defbinding widget-set-double-buffered () nil
 333   (widget widget)
 334   (double-buffered boolean))
 335
 336 (defbinding widget-set-redraw-on-allocate () nil
 337   (widget widget)
 338   (redraw-on-allocate boolean))
 339
 340 (defbinding widget-set-scroll-adjustments () boolean
 341   (widget widget)
 342   (hadjustment adjustment)
 343   (vadjustment adjustment))
 344
 345 (defbinding widget-mnemonic-activate () boolean
 346   (widget widget)
 347   (group-cycling boolean))
 348
 349 (defbinding widget-region-intersect () pointer ;gdk:region
 350   (widget widget)
 351   (region pointer)) ;gdk:region))
 352
 353 (defbinding widget-send-expose () int
 354   (widget widget)
 355   (event gdk:event))
 356
 357 (defbinding widget-get-accessible () atk:object
 358   (widget widget))
 359
 360 (defbinding widget-child-focus () boolean
 361   (widget widget)
 362   (direction direction-type))
 363
 364 (defbinding widget-child-notify () nil
 365   (widget widget)
 366   (child-property string))
 367
 368 (defbinding widget-freeze-child-notify () nil
 369   (widget widget))
 370
 371 (defbinding %widget-get-size-request () nil
 372   (widget widget)
 373   (width int :out)
 374   (height int :out))
 375
 376 (defun widget-get-size-request (widget)
 377   (multiple-value-bind (width height) (%widget-get-size-request widget)
 378      (values (unless (= width -1) width) (unless (= height -1) height))))
 379
 380 (defbinding widget-set-size-request (widget width height) nil
 381   (widget widget)
 382   ((or width -1) int)
 383   ((or height -1) int))
 384
 385 (defbinding widget-thaw-child-notify () nil
 386   (widget widget))
 387
 388
 389 ;;; Additional bindings and functions
 390
 391 (defbinding (widget-mapped-p "gtk_widget_mapped_p") () boolean
 392   (widget widget))
 393
 394 (defbinding widget-get-size-allocation () nil
 395   (widget widget)
 396   (width int :out)
 397   (height int :out))
 398
 399 (defbinding get-event-widget () widget
 400   (event gdk:event))
 401
 402 (defun (setf widget-cursor) (cursor-type widget)
 403   (let ((cursor (make-instance 'gdk:cursor :type cursor-type)))
 404     (gdk:window-set-cursor (widget-window widget) cursor)))