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

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 2000-2001 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.7 2001/12/12 20:24:41 espen Exp $
  19
  20 (in-package "GTK")
  21
  22
  23 (defmethod shared-initialize ((widget widget) names &rest initargs &key parent)
  24   (declare (ignore initargs names))
  25   (call-next-method)
  26   (when parent
  27     (let ((old-parent (widget-parent widget))
  28           (parent-widget (first (mklist parent)))
  29           (args (rest (mklist parent))))
  30       (when old-parent
  31         (container-remove old-parent widget))
  32       (apply #'container-add parent-widget widget args))))
  33
  34 (defmethod shared-initialize :after ((widget widget) names &rest initargs
  35                                      &key show-all)
  36   (declare (ignore initargs names))
  37   (when 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-slots) (slot-value object 'parent))
  44     (with-slots (parent child-slots) object
  45       (setf
  46        child-slots
  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
  53 (defun child-slot-value (widget slot)
  54   (slot-value (widget-child-slots widget) slot))
  55
  56 (defun (setf child-slot-value) (value widget slot)
  57   (setf (slot-value (widget-child-slots widget) slot) value))
  58
  59 (defmacro with-child-slots (slots widget &body body)
  60   `(with-slots ,slots (widget-child-slots ,widget)
  61      ,@body))
  62
  63 (defmacro widget-destroyed (place)
  64   `(setf ,place nil))
  65
  66 (defbinding widget-destroy () nil
  67   (widget widget))
  68
  69 (defbinding widget-unparent () nil
  70   (widget widget))
  71
  72 (defbinding widget-show () nil
  73   (widget widget))
  74
  75 (defbinding widget-show-now () nil
  76   (widget widget))
  77
  78 (defbinding widget-hide () nil
  79   (widget widget))
  80
  81 (defbinding widget-show-all () nil
  82   (widget widget))
  83
  84 (defbinding widget-hide-all () nil
  85   (widget widget))
  86
  87 (defbinding widget-map () nil
  88   (widget widget))
  89
  90 (defbinding widget-unmap () nil
  91   (widget widget))
  92
  93 (defbinding widget-realize () nil
  94   (widget widget))
  95
  96 (defbinding widget-unrealize () nil
  97   (widget widget))
  98
  99 #|
 100 (defbinding widget-add-accelerator
 101     (widget signal accel-group key modifiers flags) nil
 102   (widget widget)
 103   ((name-to-string signal) string)
 104   (accel-group accel-group)
 105   ((gdk:keyval-from-name key) unsigned-int)
 106   (modifiers gdk:modifier-type)
 107   (flags accel-flags))
 108
 109 (defbinding widget-remove-accelerator
 110     (widget accel-group key modifiers) nil
 111   (widget widget)
 112   (accel-group accel-group)
 113   ((gdk:keyval-from-name key) unsigned-int)
 114   (modifiers gdk:modifier-type))
 115
 116 (defbinding widget-accelerator-signal
 117     (widget accel-group key modifiers) unsigned-int
 118   (widget widget)
 119   (accel-group accel-group)
 120   ((gdk:keyval-from-name key) unsigned-int)
 121   (modifiers gdk:modifier-type))
 122
 123 (defbinding widget-lock-accelerators () nil
 124   (widget widget))
 125
 126 (defbinding widget-unlock-accelerators () nil
 127   (widget widget))
 128
 129 (defbinding (widget-accelerators-locked-p "gtk_widget_accelerators_locked")
 130     () boolean
 131   (widget widget))
 132 |#
 133
 134 (defbinding widget-event () int
 135   (widget widget)
 136   (event gdk:event))
 137
 138 (defbinding get-event-widget () widget
 139   (event gdk:event))
 140
 141 (defbinding widget-activate () boolean
 142   (widget widget))
 143
 144 (defbinding widget-set-scroll-adjustments () boolean
 145   (widget widget)
 146   (hadjustment adjustment)
 147   (vadjustment adjustment))
 148
 149 (defbinding widget-reparent () nil
 150   (widget widget)
 151   (new-parent widget))
 152
 153 ; (defbinding widget-popup () nil
 154 ;   (widget widget)
 155 ;   (x int)
 156 ;   (y int))
 157
 158 (defbinding widget-grab-focus () nil
 159   (widget widget))
 160
 161 (defbinding widget-grab-default () nil
 162   (widget widget))
 163
 164 (defbinding grab-add () nil
 165   (widget widget))
 166
 167 (defbinding grab-get-current () widget)
 168
 169 (defbinding grab-remove () nil
 170   (widget widget))
 171
 172 (defbinding widget-allocation () nil
 173   (widget widget)
 174   (width int :out)
 175   (height int :out))
 176
 177 (defbinding widget-add-events () nil
 178   (widget widget)
 179   (events gdk:event-mask))
 180
 181 (defbinding (widget-toplevel "gtk_widget_get_toplevel") () widget
 182   (widget widget))
 183
 184 (defbinding (widget-ancestor "gtk_widget_get_ancestor") (widget type) widget
 185   (widget widget)
 186   ((find-type-number type) type-number))
 187
 188 (defbinding (widget-pointer "gtk_widget_get_pointer") () nil
 189   (widget widget)
 190   (x int :out)
 191   (y int :out))
 192
 193 (defbinding (widget-is-ancestor-p "gtk_widget_is_ancestor") () boolean
 194   (widget widget)
 195   (ancestor widget))
 196
 197 (defbinding widget-ensure-style () nil
 198   (widget widget))
 199
 200 (defbinding widget-reset-rc-styles () nil
 201   (widget widget))
 202
 203 (defun (setf widget-cursor) (cursor-type widget)
 204   (let ((cursor (gdk:cursor-new cursor-type))
 205         (window (widget-window widget)))
 206     (gdk:window-set-cursor window cursor)
 207     ;(gdk:cursor-destroy cursor)
 208     ))
 209
 210 ;; Push/pop pairs, to change default values upon a widget's creation.
 211 ;; This will override the values that got set by the
 212 ;; widget-set-default-* functions.
 213
 214 (defbinding widget-push-colormap () nil
 215   (colormap gdk:colormap))
 216
 217 (defbinding widget-push-composite-child () nil)
 218
 219 (defbinding widget-pop-colormap () nil)
 220
 221 (defbinding widget-pop-composite-child () nil)
 222
 223
 224 ;; Set certain default values to be used at widget creation time.
 225
 226 (defbinding widget-set-default-colormap () nil
 227   (colormap gdk:colormap))
 228
 229 (defbinding widget-get-default-style () style)
 230
 231 (defbinding widget-get-default-colormap () gdk:colormap)
 232
 233 (defbinding widget-shape-combine-mask () nil
 234   (widget widget)
 235   (shape-mask gdk:bitmap)
 236   (x-offset int)
 237   (y-offset int))
 238
 239 ;; defined in gtkglue.c
 240 (defbinding widget-mapped-p () boolean
 241   (widget widget))
 242