chiark / gitweb /
~mdw / clg / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Initial checkin
[clg] / gtk / gtkwidget.lisp
diff --git a/gtk/gtkwidget.lisp b/gtk/gtkwidget.lisp
index 6097a2f1c29c9ce901c4645ea9599cf00e213c72..e04d7f731d0cdc5a33fc13a75738a4c537f9acce 100644 (file)
--- a/gtk/gtkwidget.lisp
+++ b/gtk/gtkwidget.lisp
@@ -1,5 +1,5 @@
 ;; Common Lisp bindings for GTK+ v2.0
 ;; Common Lisp bindings for GTK+ v2.0
-;; Copyright (C) 2000 Espen S. Johnsen <espejohn@online.no>
+;; Copyright (C) 2000-2002 Espen S. Johnsen <espen@users.sourceforge.net>
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -15,157 +15,38 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gtkwidget.lisp,v 1.2 2000-08-16 22:16:44 espen Exp $
+;; $Id: gtkwidget.lisp,v 1.9 2004-10-31 12:05:52 espen Exp $
 
 (in-package "GTK")
 
 
 
 (in-package "GTK")
 
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass widget (object)
-    ((child-slots
-      :allocation :instance
-      :accessor widget-child-slots
-      :type container-child)
-     (name
-      :allocation :arg
-      :accessor widget-name
-      :initarg :name
-      :type string)
-     (parent
-      :allocation :arg
-      :accessor widget-parent
-;     :initarg :parent
-      :type container)
-     (x
-      :allocation :arg
-      :accessor widget-x-position
-      :initarg :x
-      :type int)
-     (y
-      :allocation :arg
-      :accessor widget-y-position
-      :initarg :y
-      :type int)
-     (width
-      :allocation :arg
-      :accessor widget-width
-      :initarg :width
-      :type int)
-     (height
-      :allocation :arg
-      :accessor widget-height
-      :initarg :height
-      :type int)
-     (visible
-      :allocation :arg
-      :accessor widget-visible-p
-      :initarg :visible
-      :type boolean)
-     (sensitive
-      :allocation :arg
-      :accessor widget-sensitive-p
-      :initarg :sensitive
-      :type boolean)
-     (app-paintable
-      :allocation :arg
-      :reader widget-app-paintable-p
-;     :access :read-only
-      :type boolean)
-     (can-focus
-      :allocation :arg
-      :accessor widget-can-focus-p
-      :initarg :can-focus
-      :type boolean)
-     (has-focus
-      :allocation :arg
-      :accessor widget-has-focus-p
-      :initarg :has-focus
-      :type boolean)
-     (can-default
-      :allocation :arg
-      :accessor widget-can-default-p
-      :initarg :can-default
-      :type boolean)
-     (has-default
-      :allocation :arg
-      :accessor widget-has-default-p
-      :initarg :has-default
-      :type boolean)
-     (receives-default
-      :allocation :arg
-      :accessor widget-receives-default-p
-      :initarg :receives-default
-      :type boolean)
-     (composite-child
-      :allocation :arg
-      :accessor widget-composite-child-p
-      :initarg :composite-child
-      :type boolean)
-;    (style
-;     :allocation :arg
-;     :accessor widget-style
-;     :initarg :style
-;     :type style)
-     (events
-      :allocation :arg
-      :accessor widget-events
-      :initarg :events
-      :type gdk:event-mask)
-     (extension-events
-      :allocation :arg
-      :accessor widget-extension-events
-      :initarg :extpension-events
-      :type gdk:event-mask)
-     (state
-      :allocation :virtual
-      :location ("gtk_widget_get_state" "gtk_widget_set_state")
-      :accessor widget-state
-      :initarg :state
-      :type state-type)
-     (window
-      :allocation :virtual
-      :location "gtk_widget_get_window"
-      :reader widget-window
-      :type gdk:window)
-     (colormap
-      :allocation :virtual
-      :location "gtk_widget_get_colormap"
-      :reader widget-colormap
-      :type gdk:colormap)
-     (visual
-      :allocation :virtual
-      :location "gtk_widget_get_visual"
-      :reader widget-visual
-      :type gdk:visual))
-    (:metaclass object-class)
-    (:alien-name "GtkWidget")))
-
-
-(defmethod initialize-instance ((widget widget) &rest initargs &key parent)
-  (declare (ignore initargs))
-  (cond
-   ((consp parent)
-    (with-slots ((container parent) child-slots) widget
-      (setf
-       container (car parent)
-       child-slots
-       (apply
-       #'make-instance
-       (slot-value (class-of container) 'child-class)
-       :parent container :child widget (cdr parent)))))
-   (parent
-    (setf (slot-value widget 'parent) parent)))
-    (call-next-method))
+(defmethod shared-initialize ((widget widget) names &rest initargs &key parent)
+  (remf initargs :parent)
+  (prog1
+      (apply #'call-next-method widget names initargs)
+    (when parent
+      (let ((old-parent (widget-parent widget))
+           (parent (first (mklist parent)))
+           (args (rest (mklist parent))))
+       (when old-parent
+         (container-remove old-parent widget))
+       (apply #'container-add parent widget args)))))
+
+(defmethod shared-initialize :after ((widget widget) names &rest initargs
+                                    &key show-all)
+  (declare (ignore initargs names))
+  (when show-all
+    (widget-show-all widget)))
 
 
 
 
-(defmethod slot-unbound ((class object-class) (object widget) slot)
+(defmethod slot-unbound ((class gobject-class) (object widget) slot)
   (cond
    ((and (eq slot 'child-slots) (slot-value object 'parent))
     (with-slots (parent child-slots) object
       (setf
        child-slots
        (make-instance
   (cond
    ((and (eq slot 'child-slots) (slot-value object 'parent))
     (with-slots (parent child-slots) object
       (setf
        child-slots
        (make-instance
-       (slot-value (class-of parent) 'child-class)
+       (gethash (class-of parent) *container-to-child-class-mappings*)
        :parent parent :child object))))
    (t (call-next-method))))
 
        :parent parent :child object))))
    (t (call-next-method))))
 
@@ -180,43 +61,66 @@ (defmacro with-child-slots (slots widget &body body)
   `(with-slots ,slots (widget-child-slots ,widget)
      ,@body))
 
   `(with-slots ,slots (widget-child-slots ,widget)
      ,@body))
 
+
 (defmacro widget-destroyed (place)
   `(setf ,place nil))
 
 (defmacro widget-destroyed (place)
   `(setf ,place nil))
 
-(define-foreign widget-destroy () nil
+
+;;; Bindings
+
+(defbinding widget-destroy () nil
   (widget widget))
 
   (widget widget))
 
-(define-foreign widget-unparent () nil
+(defbinding widget-unparent () nil
   (widget widget))
 
   (widget widget))
 
-(define-foreign widget-show () nil
+(defbinding widget-show () nil
   (widget widget))
 
   (widget widget))
 
-(define-foreign widget-show-now () nil
+(defbinding widget-show-now () nil
   (widget widget))
 
   (widget widget))
 
-(define-foreign widget-hide () nil
+(defbinding widget-hide () nil
   (widget widget))
 
   (widget widget))
 
-(define-foreign widget-show-all () nil
+(defbinding widget-show-all () nil
   (widget widget))
 
   (widget widget))
 
-(define-foreign widget-hide-all () nil
+(defbinding widget-hide-all () nil
   (widget widget))
 
   (widget widget))
 
-(define-foreign widget-map () nil
+(defbinding widget-map () nil
   (widget widget))
 
   (widget widget))
 
-(define-foreign widget-unmap () nil
+(defbinding widget-unmap () nil
   (widget widget))
 
   (widget widget))
 
-(define-foreign widget-realize () nil
+(defbinding widget-realize () nil
   (widget widget))
 
   (widget widget))
 
-(define-foreign widget-unrealize () nil
+(defbinding widget-unrealize () nil
   (widget widget))
 
   (widget widget))
 
-(define-foreign widget-add-accelerator
+(defbinding widget-queue-draw () nil
+  (widget widget))
+
+(defbinding widget-queue-resize () nil
+  (widget widget))
+
+(defbinding widget-size-request () nil
+  (widget widget)
+  (requisition requisition))
+
+(defbinding widget-get-child-requisition () nil
+  (widget widget)
+  (requisition requisition))
+
+(defbinding widget-size-allocate () nil
+  (widget widget)
+  (allocation allocation))
+
+
+(defbinding widget-add-accelerator
     (widget signal accel-group key modifiers flags) nil
   (widget widget)
   ((name-to-string signal) string)
     (widget signal accel-group key modifiers flags) nil
   (widget widget)
   ((name-to-string signal) string)
@@ -225,179 +129,262 @@ (define-foreign widget-add-accelerator
   (modifiers gdk:modifier-type)
   (flags accel-flags))
 
   (modifiers gdk:modifier-type)
   (flags accel-flags))
 
-(define-foreign widget-remove-accelerator
+(defbinding widget-remove-accelerator
     (widget accel-group key modifiers) nil
   (widget widget)
   (accel-group accel-group)
   ((gdk:keyval-from-name key) unsigned-int)
   (modifiers gdk:modifier-type))
 
     (widget accel-group key modifiers) nil
   (widget widget)
   (accel-group accel-group)
   ((gdk:keyval-from-name key) unsigned-int)
   (modifiers gdk:modifier-type))
 
-(define-foreign widget-accelerator-signal
-    (widget accel-group key modifiers) unsigned-int
+(defbinding (widget-set-accelerator-path "gtk_widget_set_accel_path") () nil
   (widget widget)
   (widget widget)
-  (accel-group accel-group)
-  ((gdk:keyval-from-name key) unsigned-int)
-  (modifiers gdk:modifier-type))
+  (accel-path string)
+  (accel-group accel-group))
+  
 
 
-(define-foreign widget-lock-accelerators () nil
+(defbinding widget-event () int
+  (widget widget)
+  (event gdk:event))
+
+(defbinding widget-activate () boolean
   (widget widget))
 
   (widget widget))
 
-(define-foreign widget-unlock-accelerators () nil
+(defbinding widget-reparent () nil
+  (widget widget)
+  (new-parent widget))
+
+(defbinding %widget-intersect () boolean
+  (widget widget)
+  (area gdk:rectangle)
+  (intersection pointer))
+
+
+(defun widget-intersection (widget area)
+  (let ((intersection (make-instance 'gdk:rectangle)))
+    (when (%widget-intersect widget area intersection)
+      intersection)))
+
+(defun widget-intersect-p (widget area)
+  (%widget-intersect widget area (make-pointer 0)))
+
+(defbinding (widget-is-focus-p "gtk_widget_is_focus") () boolean
   (widget widget))
 
   (widget widget))
 
-(define-foreign
-    ("gtk_widget_accelerators_locked" widget-accelerators-locked-p) () boolean
+(defbinding widget-grab-focus () nil
   (widget widget))
 
   (widget widget))
 
-(define-foreign widget-event () int
-  (widget widget)
-  (event gdk:event))
+(defbinding widget-grab-default () nil
+  (widget widget))
 
 
-(define-foreign get-event-widget () widget
-  (event gdk:event))
+(defbinding widget-add-events () nil
+  (widget widget)
+  (events gdk:event-mask))
 
 
-(define-foreign widget-activate () boolean
+(defbinding widget-get-toplevel () widget
   (widget widget))
 
   (widget widget))
 
-(define-foreign widget-set-scroll-adjustments () boolean
+(defbinding widget-get-ancestor (widget type) widget
   (widget widget)
   (widget widget)
-  (hadjustment adjustment)
-  (vadjustment adjustment))
+  ((find-type-number type) type-number))
 
 
-(define-foreign widget-reparent () nil
+(defbinding widget-get-pointer () nil
   (widget widget)
   (widget widget)
-  (new-parent widget))
+  (x int :out)
+  (y int :out))
 
 
-(define-foreign widget-popup () nil
+(defbinding (widget-is-ancestor-p "gtk_widget_is_ancestor") () boolean
   (widget widget)
   (widget widget)
-  (x int)
-  (y int))
+  (ancestor widget))
 
 
-(define-foreign widget-grab-focus () nil
+(defbinding widget-translate-coordinates () boolean
+  (src-widget widget)
+  (dest-widget widget)
+  (src-x int) (src-y int)
+  (set-x int :out) (dest-y int :out))
+
+(defun widget-hide-on-delete (widget)
+  "Utility function; intended to be connected to the DELETE-EVENT
+signal on a GtkWindow. The function calls WIDGET-HIDE on its
+argument, then returns T. If connected to DELETE-EVENT, the
+result is that clicking the close button for a window (on the window
+frame, top right corner usually) will hide but not destroy the
+window. By default, GTK+ destroys windows when DELETE-EVENT is
+received."
+  (widget-hide widget)
+  t)
+  
+(defbinding widget-ensure-style () nil
   (widget widget))
 
   (widget widget))
 
-(define-foreign widget-grab-default () nil
+(defbinding widget-reset-rc-styles () nil
   (widget widget))
 
   (widget widget))
 
-(define-foreign grab-add () nil
-  (widget widget))
+(defbinding widget-push-colormap () nil
+  (colormap gdk:colormap))
 
 
-(define-foreign grab-get-current () widget)
+(defbinding widget-pop-colormap () nil)
 
 
-(define-foreign grab-remove () nil
-  (widget widget))
+(defbinding widget-set-default-colormap () nil
+  (colormap gdk:colormap))
+
+(defbinding widget-get-default-style () style)
+
+(defbinding widget-get-default-colormap () gdk:colormap)
+
+(defbinding widget-get-default-visual () gdk:visual)
+
+(defbinding widget-get-default-direction () text-direction)
 
 
-(define-foreign widget-allocation () nil
+(defbinding widget-set-default-direction () nil
+  (direction  text-direction))
+
+(defbinding widget-shape-combine-mask () nil
   (widget widget)
   (widget widget)
-  (width int :out)
-  (height int :out))
+  (shape-mask gdk:bitmap)
+  (x-offset int)
+  (y-offset int))
 
 
+(defbinding widget-path () nil
+  (widget widget)
+  (path-length int :out)
+  (path string :out)
+  (reverse-path string :out))
 
 
-(define-foreign widget-set-uposition (widget &key (x t) (y t)) nil
+(defbinding widget-class-path () nil
   (widget widget)
   (widget widget)
-  ((case x
-     ((t) -2)
-     ((nil) -1)
-     (otherwise x)) int)
-  ((case y
-     ((t) -2)
-     ((nil) -1)
-     (otherwise y)) int))
+  (path-length int :out)
+  (path string :out)
+  (reverse-path string :out))
 
 
-(define-foreign widget-add-events () nil
+(defbinding widget-modify-style () nil
   (widget widget)
   (widget widget)
-  (events gdk:event-mask))
+  (style rc-style))
 
 
-(define-foreign ("gtk_widget_get_toplevel" widget-toplevel) () widget
+(defbinding widget-modify-style () rc-style
   (widget widget))
 
   (widget widget))
 
-(define-foreign ("gtk_widget_get_ancestor"
-                 widget-ancestor) (widget type) widget
+(defbinding (widget-modify-foreground "gtk_widget_modify_fg") () nil
   (widget widget)
   (widget widget)
-  ((find-type-number type) type-number))
+  (state state-type)
+  (color gdk:color))
 
 
-; (define-foreign ("gtk_widget_get_colormap" widget-colormap) () gdk:colormap
-;   (widget widget))
+(defbinding (widget-modify-background "gtk_widget_modify_bg") () nil
+  (widget widget)
+  (state state-type)
+  (color gdk:color))
 
 
-; (define-foreign ("gtk_widget_get_visual" widget-visual) () gdk:visual
-;   (widget widget))
+(defbinding widget-modify-text () nil
+  (widget widget)
+  (state state-type)
+  (color gdk:color))
 
 
-(define-foreign ("gtk_widget_get_pointer" widget-pointer) () nil
+(defbinding widget-modify-base () nil
   (widget widget)
   (widget widget)
-  (x int :out)
-  (y int :out))
+  (state state-type)
+  (color gdk:color))
 
 
-(define-foreign ("gtk_widget_is_ancestor" widget-is-ancestor-p) () boolean
+(defbinding widget-modify-font () nil
   (widget widget)
   (widget widget)
-  (ancestor widget))
+  (state state-type)
+  (font-desc pango:font-description))
 
 
-(define-foreign widget-set-rc-style () nil
+(defbinding widget-create-pango-context () pango:context
   (widget widget))
 
   (widget widget))
 
-(define-foreign widget-ensure-style () nil
+(defbinding widget-get-pango-context () pango:context
   (widget widget))
 
   (widget widget))
 
-(define-foreign widget-restore-default-style () nil
-  (widget widget))
+(defbinding widget-create-pango-layout (widget &optional text) pango:layout
+  (widget widget)
+  (text (or string null)))
 
 
-(define-foreign widget-reset-rc-styles () nil
-  (widget widget))
+(defbinding widget-render-icon () gdk:pixbuf
+  (widget widget)
+  (stock-id string)
+  (size icon-size)
+  (detail string))
 
 
-(defun (setf widget-cursor) (cursor-type widget)
-  (let ((cursor (gdk:cursor-new cursor-type))
-       (window (widget-window widget)))
-    (gdk:window-set-cursor window cursor)
-    ;(gdk:cursor-destroy cursor)
-    ))
+(defbinding widget-push-composite-child () nil)
 
 
-;; Push/pop pairs, to change default values upon a widget's creation.
-;; This will override the values that got set by the
-;; widget-set-default-* functions.
+(defbinding widget-pop-composite-child () nil)
 
 
-(define-foreign widget-push-style () nil
-  (style style))
+(defbinding widget-queue-draw-area () nil
+  (widget widget)
+  (x int) (y int) (width int) (height int))
 
 
-(define-foreign widget-push-colormap () nil
-  (colormap gdk:colormap))
+(defbinding widget-reset-shapes () nil
+  (widget widget))
 
 
-; (define-foreign widget-push-visual () nil
-;   (visual gdk:visual))
+(defbinding widget-set-double-buffered () nil
+  (widget widget)
+  (double-buffered boolean))
 
 
-(define-foreign widget-push-composite-child () nil)
+(defbinding widget-set-redraw-on-allocate () nil
+  (widget widget)
+  (redraw-on-allocate boolean))
 
 
-(define-foreign widget-pop-style () nil)
+(defbinding widget-set-scroll-adjustments () boolean
+  (widget widget)
+  (hadjustment adjustment)
+  (vadjustment adjustment))
 
 
-(define-foreign widget-pop-colormap () nil)
+(defbinding widget-mnemonic-activate () boolean
+  (widget widget)
+  (group-cycling boolean))
 
 
-;(define-foreign widget-pop-visual () nil)
+(defbinding widget-region-intersect () pointer ;gdk:region
+  (widget widget)
+  (region pointer)) ;gdk:region))
 
 
-(define-foreign widget-pop-composite-child () nil)
+(defbinding widget-send-expose () int
+  (widget widget)
+  (event gdk:event))
 
 
+(defbinding widget-get-accessible () atk:object
+  (widget widget))
 
 
-;; Set certain default values to be used at widget creation time.
+(defbinding widget-child-focus () boolean
+  (widget widget)
+  (direction direction-type))
 
 
-(define-foreign widget-set-default-style () nil
-  (style style))
+(defbinding widget-child-notify () nil
+  (widget widget)
+  (child-property string))
 
 
-(define-foreign widget-set-default-colormap () nil
-  (colormap gdk:colormap))
+(defbinding widget-freeze-child-notify () nil
+  (widget widget))
+
+(defbinding %widget-get-size-request () nil
+  (widget widget)
+  (width int :out)
+  (height int :out))
 
 
-; (define-foreign widget-set-default-visual () nil
-;   (visual gdk:visual))
+(defun widget-get-size-request (widget)
+  (multiple-value-bind (width height) (%widget-get-size-request widget)
+    (values (unless (= width -1) width) (unless (= height -1) height))))
 
 
-(define-foreign widget-get-default-style () style)
+(defbinding widget-set-size-request (widget width height) nil
+  (widget widget)
+  ((or width -1) int)
+  ((or height -1) int))
 
 
-(define-foreign widget-get-default-colormap () gdk:colormap)
+(defbinding widget-thaw-child-notify () nil
+  (widget widget))
 
 
-(define-foreign widget-get-default-visual () gdk:visual)
 
 
-(define-foreign widget-shape-combine-mask () nil
-  (widget widget)
-  (shape-mask gdk:bitmap)
-  (x-offset int)
-  (y-offset int))
+;;; Additional bindings and functions
 
 
-;; defined in gtkglue.c
-(define-foreign widget-mapped-p () boolean
+(defbinding widget-mapped-p () boolean
   (widget widget))
 
   (widget widget))
 
+(defbinding widget-get-size-allocation () nil
+  (widget widget)
+  (width int :out)
+  (height int :out))
+
+(defbinding get-event-widget () widget
+  (event gdk:event))
+
+(defun (setf widget-cursor) (cursor-type widget)
+  (let ((cursor (make-instance 'cursor  :type cursor-type)))
+    (gdk:window-set-cursor (widget-window widget) cursor)))
Common Lisp bindings for GTK and friends (local modifications).