Shared library component improved

[clg] / gtk / gtkwidget.lisp

diff --git a/gtk/gtkwidget.lisp b/gtk/gtkwidget.lisp
index 0320921c87d64d23766ac3db5ff1f59bc70508f1..7f9aa5cb2b63498a0584daf4c7f785a17bc4a727 100644 (file)
--- a/gtk/gtkwidget.lisp
+++ b/gtk/gtkwidget.lisp
@@ -15,7 +15,7 @@
 ;; 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.13 2004-12-20 20:09:53 espen Exp $
+;; $Id: gtkwidget.lisp,v 1.15 2005-01-12 13:51:02 espen Exp $

 
 (in-package "GTK")
 
 
 (in-package "GTK")
 


@@ -37,19 +37,42 @@ (defmethod shared-initialize :after ((widget widget) names &rest initargs
   (when (or all-visible show-all)
     (widget-show-all widget)))
 
   (when (or all-visible show-all)
     (widget-show-all widget)))
 

-
-(defmethod slot-unbound ((class gobject-class) (object widget) slot)
+(defmethod slot-unbound ((class gobject-class) (object widget) 
+                        (slot (eql 'child-properties)))

   (cond
   (cond

-   ((and (eq slot 'child-properties) (slot-value object 'parent))
+   ((slot-boundp object 'parent)

     (with-slots (parent child-properties) object
     (with-slots (parent child-properties) object

-      (setf
-       child-properties
-       (make-instance
-       (gethash (class-of parent) *container-to-child-class-mappings*)
+      (setf child-properties
+       (make-instance 
+        (gethash (class-of parent) *container-to-child-class-mappings*)

        :parent parent :child object))))
        :parent parent :child object))))

-   (t (call-next-method))))
-
-
+   ((call-next-method))))
+
+(defmethod slot-boundp-using-class ((class gobject-class) (object widget) slot)
+  (or
+   (and 
+    (eq (slot-definition-name slot) 'child-properties) 
+    (slot-boundp object 'parent))
+   (call-next-method)))
+
+(defmethod create-callback-function ((widget widget) function arg1)
+  (if (eq arg1 :parent)
+      #'(lambda (&rest args)
+         (if (slot-boundp widget 'parent)
+             (apply function (widget-parent widget) (rest args))
+           ;; Delay until parent is set
+           (signal-connect widget 'parent-set
+            #'(lambda (old-parent)
+                (declare (ignore old-parent))
+                (let ((*signal-stop-emission* 
+                       #'(lambda ()
+                           (warn "Ignoring emission stop in delayed signal handler"))))
+                  (apply function (widget-parent widget) (rest args))))
+            :remove t)
+;          (warn "Widget has no parent -- ignoring signal")
+           ))
+    (call-next-method)))
+      

 (defun child-property-value (widget slot)
   (slot-value (widget-child-properties widget) slot))
 
 (defun child-property-value (widget slot)
   (slot-value (widget-child-properties widget) slot))
 


@@ -61,10 +84,6 @@ (defmacro with-child-properties (slots widget &body body)
      ,@body))
 
 
      ,@body))
 
 

-(defmacro widget-destroyed (place)
-  `(setf ,place nil))
-
-

 ;;; Bindings
 
 (defbinding widget-destroy () nil
 ;;; Bindings
 
 (defbinding widget-destroy () nil


@@ -106,19 +125,23 @@ (defbinding widget-queue-draw () nil
 (defbinding widget-queue-resize () nil
   (widget widget))
 
 (defbinding widget-queue-resize () nil
   (widget widget))
 

-(defbinding widget-size-request () nil
+(defbinding widget-queue-resize-no-redraw () nil
+  (widget widget))
+
+(defbinding widget-size-request
+    (widget &optional (requisition (make-instance 'requisition))) nil

   (widget widget)
   (widget widget)

-  (requisition requisition))
+  (requisition requisition :return))

 
 

-(defbinding widget-get-child-requisition () nil
+(defbinding widget-get-child-requisition 
+    (widget &optional (requisition (make-instance 'requisition))) nil

   (widget widget)
   (widget widget)

-  (requisition requisition))
+  (requisition requisition :return))

 
 (defbinding widget-size-allocate () nil
   (widget widget)
   (allocation allocation))
 
 
 (defbinding widget-size-allocate () nil
   (widget widget)
   (allocation allocation))
 

-

 (defbinding widget-add-accelerator
     (widget signal accel-group key modifiers flags) nil
   (widget widget)
 (defbinding widget-add-accelerator
     (widget signal accel-group key modifiers flags) nil
   (widget widget)


@@ -135,13 +158,19 @@ (defbinding widget-remove-accelerator
   ((gdk:keyval-from-name key) unsigned-int)
   (modifiers gdk:modifier-type))
 
   ((gdk:keyval-from-name key) unsigned-int)
   (modifiers gdk:modifier-type))
 

-(defbinding (widget-set-accelerator-path "gtk_widget_set_accel_path") () nil
+(defbinding widget-set-accel-path () nil

   (widget widget)
   (accel-path string)
   (accel-group accel-group))
   (widget widget)
   (accel-path string)
   (accel-group accel-group))

-  

 
 

-(defbinding widget-event () int
+(defbinding widget-list-accel-closures () (glist pointer)
+  (widget widget))
+
+(defbinding widget-can-activate-accel-p () boolean
+  (widget widget)
+  (signal-id unsigned-int))
+
+(defbinding widget-event () boolean

   (widget widget)
   (event gdk:event))
 
   (widget widget)
   (event gdk:event))
 


@@ -165,9 +194,6 @@ (defun widget-intersection (widget area)
 (defun widget-intersect-p (widget area)
   (%widget-intersect widget area nil))
 
 (defun widget-intersect-p (widget area)
   (%widget-intersect widget area nil))
 

-;; (defbinding (widget-is-focus-p "gtk_widget_is_focus") () boolean
-;;   (widget widget))
-

 (defbinding widget-grab-focus () nil
   (widget widget))
 
 (defbinding widget-grab-focus () nil
   (widget widget))
 


@@ -190,7 +216,7 @@ (defbinding widget-get-pointer () nil
   (x int :out)
   (y int :out))
 
   (x int :out)
   (y int :out))
 

-(defbinding (widget-is-ancestor-p "gtk_widget_is_ancestor") () boolean
+(defbinding widget-is-ancestor-p () boolean

   (widget widget)
   (ancestor widget))
 
   (widget widget)
   (ancestor widget))
 


@@ -202,7 +228,7 @@ (defbinding widget-translate-coordinates () boolean
 
 (defun widget-hide-on-delete (widget)
   "Utility function; intended to be connected to the DELETE-EVENT
 
 (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
+signal on a WINDOW. 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
 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


@@ -222,23 +248,34 @@ (defbinding widget-push-colormap () nil
 
 (defbinding widget-pop-colormap () nil)
 
 
 (defbinding widget-pop-colormap () nil)
 

-(defbinding widget-set-default-colormap () nil
+(defbinding %widget-set-default-colormap () nil

   (colormap gdk:colormap))
 
   (colormap gdk:colormap))
 

-(defbinding widget-get-default-style () style)
+(defun (setf widget-default-colormap) (colormap)
+  (%widget-set-default-colormap colormap)
+  colormap)
+
+(defbinding (widget-default-style "gtk_widget_get_default_style") () style)
+
+(defbinding (widget-default-colromap "gtk_widget_get_default_colormap") 
+    () gdk:colormap)

 
 

-(defbinding widget-get-default-colormap () gdk:colormap)
+(defbinding (widget-default-visual "gtk_widget_get_default_visual") 
+    () gdk:visual)

 
 

-(defbinding widget-get-default-visual () gdk:visual)
+(defbinding (widget-default-direction "gtk_widget_get_default_direction")
+    () text-direction)

 
 

-(defbinding widget-get-default-direction () text-direction)
+(defbinding %widget-set-default-direction () nil
+  (direction text-direction))

 
 

-(defbinding widget-set-default-direction () nil
-  (direction  text-direction))
+(defun (setf widget-default-direction) (direction)
+  (%widget-set-default-direction direction)
+  direction)

 
 (defbinding widget-shape-combine-mask () nil
   (widget widget)
 
 (defbinding widget-shape-combine-mask () nil
   (widget widget)

-  (shape-mask gdk:bitmap)
+  (shape-mask (or null gdk:bitmap))

   (x-offset int)
   (y-offset int))
 
   (x-offset int)
   (y-offset int))
 


@@ -258,15 +295,15 @@ (defbinding widget-modify-style () nil
   (widget widget)
   (style rc-style))
 
   (widget widget)
   (style rc-style))
 

-(defbinding widget-modify-style () rc-style
+(defbinding widget-get-modifier-style () rc-style

   (widget widget))
 
   (widget widget))
 

-(defbinding (widget-modify-foreground "gtk_widget_modify_fg") () nil
+(defbinding widget-modify-fg () nil

   (widget widget)
   (state state-type)
   (color gdk:color))
 
   (widget widget)
   (state state-type)
   (color gdk:color))
 

-(defbinding (widget-modify-background "gtk_widget_modify_bg") () nil
+(defbinding widget-modify-bg () nil

   (widget widget)
   (state state-type)
   (color gdk:color))
   (widget widget)
   (state state-type)
   (color gdk:color))


@@ -296,11 +333,12 @@ (defbinding widget-create-pango-layout (widget &optional text) pango:layout
   (widget widget)
   (text (or string null)))
 
   (widget widget)
   (text (or string null)))
 

-(defbinding widget-render-icon () gdk:pixbuf
+(defbinding widget-render-icon (widget stock-id &optional size detail) 
+    gdk:pixbuf

   (widget widget)
   (stock-id string)
   (widget widget)
   (stock-id string)

-  (size icon-size)
-  (detail string))
+  ((or size -1) (or icon-size int))
+  (detail (or null string)))

 
 (defbinding widget-push-composite-child () nil)
 
 
 (defbinding widget-push-composite-child () nil)
 


@@ -313,31 +351,53 @@ (defbinding widget-queue-draw-area () nil
 (defbinding widget-reset-shapes () nil
   (widget widget))
 
 (defbinding widget-reset-shapes () nil
   (widget widget))
 

-(defbinding widget-set-double-buffered () nil
-  (widget widget)
-  (double-buffered boolean))
+;; (defbinding widget-set-double-buffered () nil
+;;   (widget widget)
+;;   (double-buffered boolean))

 
 

-(defbinding widget-set-redraw-on-allocate () nil
-  (widget widget)
-  (redraw-on-allocate boolean))
+;; (defbinding widget-set-redraw-on-allocate () nil
+;;   (widget widget)
+;;   (redraw-on-allocate boolean))

 
 (defbinding widget-set-scroll-adjustments () boolean
   (widget widget)
 
 (defbinding widget-set-scroll-adjustments () boolean
   (widget widget)

-  (hadjustment adjustment)
-  (vadjustment adjustment))
+  (hadjustment (or null adjustment))
+  (vadjustment (or null adjustment)))

 
 (defbinding widget-mnemonic-activate () boolean
   (widget widget)
   (group-cycling boolean))
 
 
 (defbinding widget-mnemonic-activate () boolean
   (widget widget)
   (group-cycling boolean))
 

+(defbinding widget-class-find-style-property (class name) param
+  ((type-class-peek class) pointer)
+  (name string))
+
+(defbinding widget-class-list-style-properties (class)
+    (vector (copy-of param) n-properties)
+  ((type-class-peek class) pointer)
+  (n-properties unsigned-int :out))
+

 (defbinding widget-region-intersect () pointer ;gdk:region
   (widget widget)
   (region pointer)) ;gdk:region))
 
 (defbinding widget-region-intersect () pointer ;gdk:region
   (widget widget)
   (region pointer)) ;gdk:region))
 

-(defbinding widget-send-expose () int
+(defbinding widget-send-expose () boolean

   (widget widget)
   (event gdk:event))
 
   (widget widget)
   (event gdk:event))
 

+(defbinding %widget-style-get-property () nil
+  (widget widget)
+  (name string)
+  (value gvalue))
+
+(defun style-property-value (widget style)
+  (let* ((name (string-downcase style))
+        (param (widget-class-find-style-property (class-of widget) name)))
+    (if (not param)
+       (error "~A has no such style property: ~A" widget style)
+      (with-gvalue (gvalue (param-value-type param))
+        (%widget-style-get-property widget (string-downcase style) gvalue)))))
+

 (defbinding widget-get-accessible () atk:object
   (widget widget))
 
 (defbinding widget-get-accessible () atk:object
   (widget widget))
 


@@ -352,6 +412,22 @@ (defbinding widget-child-notify () nil
 (defbinding widget-freeze-child-notify () nil
   (widget widget))
 
 (defbinding widget-freeze-child-notify () nil
   (widget widget))
 

+(defbinding widget-get-clipboard () clipboard
+  (widget widget)
+  (selection int #|gdk:atom|#))
+
+(defbinding widget-get-display () gdk:display
+  (widget widget))
+
+(defbinding widget-get-root-window () gdk:window
+  (widget widget))
+
+(defbinding widget-get-screen () gdk:screen
+  (widget widget))
+
+(defbinding widget-has-screen-p () boolean
+  (widget widget))
+

 (defbinding %widget-get-size-request () nil
   (widget widget)
   (width int :out)
 (defbinding %widget-get-size-request () nil
   (widget widget)
   (width int :out)


@@ -369,6 +445,17 @@ (defbinding widget-set-size-request (widget width height) nil
 (defbinding widget-thaw-child-notify () nil
   (widget widget))
 
 (defbinding widget-thaw-child-notify () nil
   (widget widget))
 

+(defbinding widget-list-mnemonic-labels () (glist widget)
+  (widget widget))
+
+(defbinding widget-add-mnemonic-label () nil
+  (widget widget)
+  (label widget))
+
+(defbinding widget-remove-mnemonic-label () nil
+  (widget widget)
+  (label widget))
+

 
 ;;; Additional bindings and functions
 
 
 ;;; Additional bindings and functions
 


@@ -386,3 +473,10 @@ (defbinding get-event-widget () widget
 (defun (setf widget-cursor) (cursor-type widget)
   (let ((cursor (make-instance 'gdk:cursor :type cursor-type)))
     (gdk:window-set-cursor (widget-window widget) cursor)))
 (defun (setf widget-cursor) (cursor-type widget)
   (let ((cursor (make-instance 'gdk:cursor :type cursor-type)))
     (gdk:window-set-cursor (widget-window widget) cursor)))

+
+(defbinding %widget-get-parent-window () gdk:window
+  (widget widget))
+
+(defun %widget-parent-window (widget)
+  (when (slot-boundp widget 'parent)
+    (%widget-get-parent-window widget)))