From: Olof-Joachim Frahm <Olof.Frahm@web.de>
Date: Sun, 5 Sep 2010 23:58:00 +0000 (+0200)
Subject: Merge branch 'master' of git://github.com/dmitryvk/cl-gtk2 into gdk-pixbuf
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=2eb955f84e825417a84ceb0a6e6f32ea5385c548;hp=1172a48a4c54cd56da352df8104d503c08973cce;p=cl-gtk2.git

Merge branch 'master' of git://github.com/dmitryvk/cl-gtk2 into gdk-pixbuf
---

diff --git a/gdk/gdk.objects.lisp b/gdk/gdk.objects.lisp
index 3c540be..14cb5be 100644
--- a/gdk/gdk.objects.lisp
+++ b/gdk/gdk.objects.lisp
@@ -435,6 +435,22 @@
   (:bilevel 0)
   (:full 1))
 
+(define-g-enum "GdkInterpType"
+    gdk-interp-type
+    (:export t :type-initializer "gdk_interp_type_get_type")
+  (:nearest 0)
+  (:tiles 1)
+  (:bilinear 2)
+  (:hyper 3))
+
+(define-g-enum "GdkPixbufRotation"
+    gdk-pixbuf-rotation
+    (:export t :type-initializer "gdk_pixbuf_rotation_get_type")
+  (:none 0)
+  (:counterclockwise 90)
+  (:upsidedown 180)
+  (:clockwise 270))
+
 (define-g-enum "GdkColorspace" colorspace ()
   :rgb)
 
@@ -937,7 +953,7 @@
   ((:cffi visual colormap-visual (g-object visual)
           "gdk_colormap_get_visual" nil)
    (:cffi screen colormap-screen (g-object screen)
-          "gdk_colormap_get_screeen" nil)))
+          "gdk_colormap_get_screen" nil)))
 
 (define-g-object-class "GdkScreen" screen (:type-initializer "gdk_screen_get_type")
   ((font-options screen-font-options "font-options" "gpointer" t t)
diff --git a/gdk/gdk.pixbufs.lisp b/gdk/gdk.pixbufs.lisp
index 91c7427..1908e96 100644
--- a/gdk/gdk.pixbufs.lisp
+++ b/gdk/gdk.pixbufs.lisp
@@ -106,3 +106,90 @@
   (gdk-pixbuf-get-from-image pixbuf image (null-pointer) src-x src-y dest-x dest-y width height))
 
 (export 'pixbuf-get-from-image)
+
+(defcfun gdk-pixbuf-scale-simple (g-object pixbuf :already-referenced)
+  (src (g-object pixbuf))
+  (dest-width :int)
+  (dest-height :int)
+  (interp-type gdk-interp-type))
+
+(defun pixbuf-scale-simple (pixbuf dest-width dest-height &key (interp-type :bilinear))
+  (gdk-pixbuf-scale-simple pixbuf dest-width dest-height interp-type))
+
+(export 'pixbuf-scale-simple)
+
+(defcfun (pixbuf-scale "gdk_pixbuf_scale") :void
+  (src (g-object pixbuf))
+  (dest (g-object pixbuf))
+  (dest-x :int)
+  (dest-y :int)
+  (dest-width :int)
+  (dest-height :int)
+  (offset-x :double)
+  (offset-y :double)
+  (scale-x :double)
+  (scale-y :double)
+  (interp-type gdk-interp-type))
+
+(export 'pixbuf-scale)
+
+(defcfun (pixbuf-composite-color-simple "gdk_pixbuf_composite_color_simple") (g-object pixbuf :already-referenced)
+  (src (g-object pixbuf))
+  (dest-width :int)
+  (dest-height :int)
+  (interp-type gdk-interp-type)
+  (overall-alpha :int)
+  (check-size :int)
+  (color-1 :uint32)
+  (color-2 :uint32))
+
+(export 'pixbuf-composite-color-simple)
+
+(defcfun (pixbuf-composite "gdk_pixbuf_composite") :void
+  (src (g-object pixbuf))
+  (dest (g-object pixbuf))
+  (dest-x :int)
+  (dest-y :int)
+  (dest-width :int)
+  (dest-height :int)
+  (offset-x :double)
+  (offset-y :double)
+  (scale-x :double)
+  (scale-y :double)
+  (interp-type gdk-interp-type)
+  (overall-alpha :int))
+
+(export 'pixbuf-composite)
+
+(defcfun (pixbuf-composite-color "gdk_pixbuf_composite_color") :void
+  (src (g-object pixbuf))
+  (dest (g-object pixbuf))
+  (dest-x :int)
+  (dest-y :int)
+  (dest-width :int)
+  (dest-height :int)
+  (offset-x :double)
+  (offset-y :double)
+  (scale-x :double)
+  (scale-y :double)
+  (interp-type gdk-interp-type)
+  (overall-alpha :int)
+  (check-x :int)
+  (check-y :int)
+  (check-size :int)
+  (color-1 :uint32)
+  (color-2 :uint32))
+
+(export 'pixbuf-composite-color)
+
+(defcfun (pixbuf-rotate-simple "gdk_pixbuf_rotate_simple") (g-object pixbuf :already-referenced)
+  (src (g-object pixbuf))
+  (angle gdk-pixbuf-rotation))
+
+(export 'pixbuf-rotate-simple)
+
+(defcfun (pixbuf-flip "gdk_pixbuf_flip") (g-object pixbuf :already-referenced)
+  (src (g-object pixbuf))
+  (horizontal :boolean))
+
+(export 'pixbuf-flip)
diff --git a/generating.lisp b/generating.lisp
index 9e58e08..885ef96 100644
--- a/generating.lisp
+++ b/generating.lisp
@@ -191,6 +191,9 @@
          nil "gtk_menu_tool_button_set_arrow_tooltip_text")
         (:cffi gtk::arrow-tooltip-markup gtk::menu-tool-button-arrow-tooltip-markup :string
          nil "gtk_menu_tool_button_set_arrow_tooltip_markup"))
+       ("GtkRadioButton"
+        (:cffi gtk::group gtk::radio-button-group (gslist gtk::radio-button :free-from-foreign nil :free-to-foreign nil)
+         nil "gtk_radio_button_set_group"))
        ("GtkUIManager"
         (:cffi gtk::accel-group gtk::ui-manager-accel-group g-object
          "gtk_ui_manager_get_accel_group" nil))
diff --git a/glib/cl-gtk2-glib.asd b/glib/cl-gtk2-glib.asd
index 908923f..92dcb35 100644
--- a/glib/cl-gtk2-glib.asd
+++ b/glib/cl-gtk2-glib.asd
@@ -11,6 +11,7 @@
                (:file "glib.quark")
                (:file "glib.gerror")
                (:file "glib.utils")
+               (:file "glib.rand")
 
                (:file "gobject.init")
                (:file "gobject.ffi.package")
diff --git a/glib/glib.glist.lisp b/glib/glib.glist.lisp
index 22ea6bc..1a8ff3c 100644
--- a/glib/glib.glist.lisp
+++ b/glib/glib.glist.lisp
@@ -51,6 +51,8 @@
   (data :pointer)
   (next :pointer))
 
+(defcfun g-slist-alloc (:pointer g-slist))
+
 (defcfun g-slist-free :void (list (:pointer g-slist)))
 
 (defun g-slist-next (list)
@@ -64,4 +66,19 @@
             (until (null-pointer-p c))
             (collect (convert-from-foreign (foreign-slot-value c 'g-slist 'data) (gslist-type-type type))))
     (when (gslist-type-free-from-foreign type)
-      (g-slist-free pointer))))
\ No newline at end of file
+      (g-slist-free pointer))))
+
+(defmethod translate-to-foreign (list (type gslist-type))
+  (let ((result (null-pointer)) last)
+    (iter (for item in list)
+          (for n = (g-slist-alloc))
+          (for ptr = (convert-to-foreign item (gslist-type-type type)))
+          (setf (foreign-slot-value n 'g-slist 'data) ptr)
+          (setf (foreign-slot-value n 'g-slist 'next) (null-pointer))
+          (when last
+            (setf (foreign-slot-value last 'g-slist 'next) n))
+          (setf last n)
+          (when (first-iteration-p)
+            (setf result n)))
+    result))
+
diff --git a/glib/glib.rand.lisp b/glib/glib.rand.lisp
new file mode 100644
index 0000000..4849f73
--- /dev/null
+++ b/glib/glib.rand.lisp
@@ -0,0 +1,32 @@
+(in-package :glib)
+
+(defcfun (random-set-seed "g_random_set_seed") :void
+  (seed :uint32))
+
+(export 'random-set-seed)
+
+(defcfun (random-int "g_random_int") :uint32)
+
+(export 'random-int)
+
+(defcfun (random-int-range "g_random_int_range") :int32
+  (begin :int32)
+  (end :int32))
+
+(export 'random-int-range)
+
+(defun random-boolean ()
+  (logtest (random-int) #X8000))
+
+(export 'random-boolean)
+
+(defcfun (random-double "g_random_double") :double)
+
+(export 'random-double)
+
+(defcfun (random-double-range "g_random_double_range") :double
+  (begin :double)
+  (end :double))
+
+(export 'random-double-range)
+
diff --git a/gtk/cl-gtk2-gtk.asd b/gtk/cl-gtk2-gtk.asd
index c825c29..3d09695 100644
--- a/gtk/cl-gtk2-gtk.asd
+++ b/gtk/cl-gtk2-gtk.asd
@@ -24,6 +24,7 @@
                (:file "gtk.functions")
                (:file "gtk.base-classes")
                (:file "gtk.dialog")
+               (:file "gtk.about-dialog")
                (:file "gtk.window")
                (:file "gtk.window-group")
                (:file "gtk.icon-factory")
diff --git a/gtk/gtk.about-dialog.lisp b/gtk/gtk.about-dialog.lisp
new file mode 100644
index 0000000..2d36cdc
--- /dev/null
+++ b/gtk/gtk.about-dialog.lisp
@@ -0,0 +1,60 @@
+(in-package :gtk)
+
+(defvar *about-dialog-url-func* nil)
+
+(defcallback about-dialog-url-func-cb :void
+  ((dialog (g-object about-dialog)) (link (:string :free-from-foreign nil)) (user-data :pointer))
+  (declare (ignore user-data))
+  (funcall *about-dialog-url-func* dialog link))
+
+(defcallback about-dialog-url-func-destroy-cb :void
+  ((data :pointer))
+  (declare (ignore data))
+  (setf *about-dialog-url-func* nil))
+
+(defcfun gtk-about-dialog-set-url-hook :void
+  (func :pointer)
+  (data :pointer)
+  (destroy-notify :pointer))
+
+(defun (setf about-dialog-global-url-hook) (new-value)
+  (if new-value
+      (gtk-about-dialog-set-url-hook (callback about-dialog-url-func-cb)
+				     (null-pointer)
+				     (callback about-dialog-url-func-destroy-cb))
+      (gtk-about-dialog-set-url-hook (null-pointer)
+				     (null-pointer)
+				     (null-pointer)))
+  (setf *about-dialog-url-func* new-value))
+
+(export 'about-dialog-global-url-hook)
+
+(defvar *about-dialog-email-func* nil)
+
+(defcallback about-dialog-email-func-cb :void
+  ((dialog (g-object about-dialog)) (link (:string :free-from-foreign nil)) (user-data :pointer))
+  (declare (ignore user-data))
+  (funcall *about-dialog-email-func* dialog link))
+
+(defcallback about-dialog-email-func-destroy-cb :void
+  ((data :pointer))
+  (declare (ignore data))
+  (setf *about-dialog-email-func* nil))
+
+(defcfun gtk-about-dialog-set-email-hook :void
+  (func :pointer)
+  (data :pointer)
+  (destroy-notify :pointer))
+
+(defun (setf about-dialog-global-email-hook) (new-value)
+  (if new-value
+      (gtk-about-dialog-set-email-hook (callback about-dialog-email-func-cb)
+				       (null-pointer)
+				       (callback about-dialog-email-func-destroy-cb))
+      (gtk-about-dialog-set-email-hook (null-pointer)
+				       (null-pointer)
+				       (null-pointer)))
+  (setf *about-dialog-email-func* new-value))
+
+(export 'about-dialog-global-email-hook)
+
diff --git a/gtk/gtk.generated-classes.lisp b/gtk/gtk.generated-classes.lisp
index 6c98971..fa8a81f 100644
--- a/gtk/gtk.generated-classes.lisp
+++ b/gtk/gtk.generated-classes.lisp
@@ -1696,8 +1696,10 @@
                        (:superclass check-button :export t :interfaces
                         ("AtkImplementorIface" "GtkActivatable" "GtkBuildable")
                         :type-initializer "gtk_radio_button_get_type")
-                       ((group radio-button-group "group" "GtkRadioButton" nil
-                         t)))
+                       ((:cffi group radio-button-group
+                         (gslist g-object :free-from-foreign nil
+                          :free-to-foreign nil)
+                         "gtk_radio_button_get_group" "gtk_radio_button_set_group")))
 
 (define-g-object-class "GtkComboBox" combo-box
                        (:superclass bin :export t :interfaces
diff --git a/gtk/gtk.tree-model.lisp b/gtk/gtk.tree-model.lisp
index 4b8f813..edbcbd1 100644
--- a/gtk/gtk.tree-model.lisp
+++ b/gtk/gtk.tree-model.lisp
@@ -547,10 +547,11 @@
   (gethash id (tree-lisp-store-id-map tree)))
 
 (defmethod tree-model-get-iter-impl ((store tree-lisp-store) iter path)
-  (let* ((node (get-node-by-path store path))
-         (node-idx (get-assigned-id store node)))
-    (setf (tree-iter-stamp iter) 0
-          (tree-iter-user-data iter) node-idx)))
+  (ignore-errors
+    (let* ((node (get-node-by-path store path))
+	   (node-idx (get-assigned-id store node)))
+      (setf (tree-iter-stamp iter) 0
+	    (tree-iter-user-data iter) node-idx))))
 
 (defun get-node-by-iter (tree iter)
   (get-node-by-id tree (tree-iter-user-data iter)))
diff --git a/gtk/gtk.tree-view-column.lisp b/gtk/gtk.tree-view-column.lisp
index da1e3a1..ca86c4c 100644
--- a/gtk/gtk.tree-view-column.lisp
+++ b/gtk/gtk.tree-view-column.lisp
@@ -48,7 +48,7 @@
   (free-stable-pointer data))
 
 (defcfun gtk-tree-view-column-set-cell-data-func :void
-  (tree-column (g-object tree-column))
+  (tree-column (g-object tree-view-column))
   (cell-renderer (g-object cell-renderer))
   (func :pointer)
   (func-data :pointer)
@@ -62,6 +62,8 @@
    (allocate-stable-pointer function)
    (callback gtk-tree-cell-data-func-destroy-cb)))
 
+(export 'tree-view-column-set-cell-data-function)
+
 (defcfun (tree-view-column-clear-attributes "gtk_tree_view_column_clear_attributes") :void
   (tree-column (g-object tree-column))
   (cell-renderer (g-object cell-renderer)))
diff --git a/gtk/ui-markup.lisp b/gtk/ui-markup.lisp
index bb3c090..f64c4d4 100644
--- a/gtk/ui-markup.lisp
+++ b/gtk/ui-markup.lisp
@@ -45,88 +45,75 @@
                           (unless (eq (ui-prop-name prop) :var)
                             (appending (list (ui-prop-name prop) (ui-prop-value prop)))))))
 
-(defvar *ui-child-packers* (make-hash-table))
-
-(defmacro def-ui-child-packer (class (var child-def child) &body body)
-  `(setf (gethash ',class *ui-child-packers*)
-         (lambda (,var ,child-def ,child) ,@body)))
-
-(def-ui-child-packer container (w d child)
-  (declare (ignore d))
-  `(container-add ,w ,child))
-
-(defun get-ui-child-prop-value (d name required-p context)
-  (let ((prop (find name (ui-child-props d) :key #'ui-prop-name)))
-    (if (and required-p (null prop))
-        (error "~A is a mandatory child property for ~A" name context)
-        (when prop (ui-prop-value prop)))))
-
-(def-ui-child-packer box (b d child)
-  (let ((expand-prop (find :expand (ui-child-props d) :key #'ui-prop-name))
-        (fill-prop (find :fill (ui-child-props d) :key #'ui-prop-name))
-        (padding-prop (find :padding (ui-child-props d) :key #'ui-prop-name))
-        (pack-type-prop (find :pack-type (ui-child-props d) :key #'ui-prop-name)))
-    `(progn
-       (box-pack-start ,b ,child
-                       ,@(when expand-prop (list :expand (ui-prop-value expand-prop)))
-                       ,@(when fill-prop (list :fill (ui-prop-value fill-prop)))
-                       ,@(when padding-prop (list :padding (ui-prop-value padding-prop))))
-       ,@(when pack-type-prop
-               (list `(setf (box-child-pack-type ,b ,child) ,(ui-prop-value pack-type-prop)))))))
-
-(def-ui-child-packer paned (p d child)
-  (let ((resize-prop (find :resize (ui-child-props d) :key #'ui-prop-name))
-        (shrink-prop (find :shrink (ui-child-props d) :key #'ui-prop-name)))
-    `(if (null (paned-child-1 ,p))
-         (paned-pack-1 ,p ,child
-                       ,@(when resize-prop (list :resize (ui-prop-value resize-prop)))
-                       ,@(when shrink-prop (list :shrink (ui-prop-value shrink-prop))))
-         (paned-pack-2 ,p ,child
-                       ,@(when resize-prop (list :resize (ui-prop-value resize-prop)))
-                       ,@(when shrink-prop (list :shrink (ui-prop-value shrink-prop)))))))
-
-(def-ui-child-packer table (table d child)
-  `(table-attach ,table ,child
-                 ,(get-ui-child-prop-value d :left t "table packing")
-                 ,(get-ui-child-prop-value d :right t "table packing")
-                 ,(get-ui-child-prop-value d :top t "table packing")
-                 ,(get-ui-child-prop-value d :bottom t "table packing")
-                 ,@(let ((x-options (get-ui-child-prop-value d :x-options nil nil)))
-                        (when x-options
-                          (list :x-options x-options)))
-                 ,@(let ((y-options (get-ui-child-prop-value d :y-options nil nil)))
-                        (when y-options
-                          (list :y-options y-options)))
-                 ,@(let ((x-padding (get-ui-child-prop-value d :x-padding nil nil)))
-                        (when x-padding
-                          (list :x-padding x-padding)))
-                 ,@(let ((y-padding (get-ui-child-prop-value d :y-padding nil nil)))
-                        (when y-padding
-                          (list :y-padding y-padding)))))
-
-(defun get-child-packer-fn (d)
-  (iter (for class first (find-class (ui-d-class d)) then (first (c2mop:class-direct-superclasses class)))
-        (while class)
-        (for packer = (gethash (class-name class) *ui-child-packers*))
-        (when packer (return packer))))
-
-(defun get-child-packer (d var)
-  (let ((fn (get-child-packer-fn d)))
-    (when fn
-      (let ((forms (iter (for child in (ui-d-children d))
-                         (for child-var = (ui-d-var (ui-child-v child)))
-                         (collect (funcall fn var child child-var)))))
-        (when forms (cons 'progn forms))))))
-
-(defun get-ui-d-initializer (d var)
-  (get-child-packer d var))
+(defgeneric pack-child (container child &key))
+
+(defmethod pack-child ((w container) child &key)
+  (container-add w child))
+
+(defmethod pack-child ((b box) child &key (expand t) (fill t) (padding 0) pack-type position)
+  (box-pack-start b child
+		  :expand expand
+		  :fill fill
+		  :padding padding)
+  (when pack-type
+    (setf (box-child-pack-type b child) pack-type))
+  (when position
+    (setf (box-child-position b child) position)))
+
+(defmethod pack-child ((p paned) child &key (resize 'default) (shrink t))
+  (if (null (paned-child-1 p))
+      (paned-pack-1 p child
+		    :resize (if (eq resize 'default) nil resize)
+		    :shrink shrink)
+      (paned-pack-2 p child
+		    :resize (if (eq resize 'default) t resize)
+		    :shrink shrink)))
+
+(defmethod pack-child ((table table) child &key
+		       left right top bottom
+		       (x-options '(:expand :fill)) (y-options '(:expand :fill)) (x-padding 0) (y-padding 0))
+
+  (unless left
+    (error "left is a mandatory child property for table packing"))
+  (unless right
+    (error "right is a mandatory child property for table packing"))
+  (unless top
+    (error "top is a mandatory child property for table packing"))
+  (unless bottom
+    (error "bottom is a mandatory child property for table packing"))
+
+  (table-attach table child
+		:left left
+		:right right
+		:top top
+		:bottom bottom
+		:x-options x-options
+		:y-options y-options
+		:x-padding x-padding
+		:y-padding y-padding))
+
+(defmethod pack-child ((w tree-view) child &key)
+  (tree-view-append-column w child))
+
+(defmethod pack-child ((w tree-view-column) child &key (expand t) attributes)
+  (tree-view-column-pack-start w child :expand expand)
+  (iter (for a on attributes by #'cddr)
+	(tree-view-column-add-attribute w child
+					(first a)
+					(second a))))
+
+(defmethod pack-child ((b toolbar) child &key (expand 'default) (homogeneous 'default))
+  (toolbar-insert b child -1)
+  (unless (eq expand 'default)
+    (container-call-set-property b child "expand" expand +g-type-boolean+))
+  (unless (eq homogeneous 'default)
+    (container-call-set-property b child "homogeneous" homogeneous +g-type-boolean+)))
 
 (defun set-ui-expansion-1 (d)
   (when (ui-d-class d)
     ;; only direct-vars do not have class
     (setf (ui-d-var d) (get-ui-d-var d)
-          (ui-d-initform d) (get-ui-d-initform d))
-    (setf (ui-d-initializer d) (get-ui-d-initializer d (ui-d-var d)))))
+          (ui-d-initform d) (get-ui-d-initform d))))
 
 (defun set-ui-expansion (description)
   (iter (for child in (ui-d-children description))
@@ -143,10 +130,16 @@
   (let* ((description (parse-ui-description ui-description))
          (items (flattened-ui-descriptions description)))
     (set-ui-expansion description)
-    `(let (,@(iter (for i in items)
-                   (collect (list (ui-d-var i)
-                                  (ui-d-initform i)))))
-       ,@(iter (for i in items)
-               (when (ui-d-initializer i)
-                 (collect (ui-d-initializer i))))
+    `(let (,@(iter (for item in items)
+                   (collect (list (ui-d-var item)
+                                  (ui-d-initform item)))))
+       ,@(iter (for item in items)
+	       (appending (iter (for child in (ui-d-children item))
+				(for child-var = (ui-d-var (ui-child-v child)))
+				(let ((props
+				       (iter (for p in (ui-child-props child))
+					     (appending (list (ui-prop-name p) (ui-prop-value p))))))
+				  (collect (list* 'pack-child (ui-d-var item) child-var props))))))
+       
        ,@body)))
+