X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/d76e9fca7e252fb02a17d64d3e1c3025de3a2670..842e5ffe2acf8474415544a32657c5948d72a2c4:/gtk/gtk.lisp

diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp
index f470588..af78c09 100644
--- a/gtk/gtk.lisp
+++ b/gtk/gtk.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
 
-;; $Id: gtk.lisp,v 1.28 2004-12-29 21:17:36 espen Exp $
+;; $Id: gtk.lisp,v 1.30 2005-01-12 13:38:18 espen Exp $
 
 
 (in-package "GTK")
@@ -102,6 +102,30 @@ (defbinding adjustment-clamp-page () nil
   (upper single-float))
 
 
+;;; Alignment
+
+(defbinding alignment-set () nil
+  (alognment alignment)
+  (x-align single-float)
+  (y-align single-float)
+  (x-scale single-float)
+  (y-scale single-float))
+
+(defbinding alignment-get-padding () nil
+  (alognment alignment)
+  (top unsigned-int :out)
+  (bottom unsigned-int :out)
+  (left unsigned-int :out)
+  (right unsigned-int :out))
+
+(defbinding alignment-set-padding () nil
+  (alognment alignment)
+  (top unsigned-int)
+  (bottom unsigned-int)
+  (left unsigned-int)
+  (right unsigned-int))
+
+
 ;;; Aspect frame
 
 
@@ -113,9 +137,11 @@ (defun (setf bin-child) (child bin)
   (container-add bin child)
   child)
 
-
-;;; Binding
-
+(defmethod create-callback-function ((bin bin) function arg1)
+  (if (eq arg1 :child)
+      #'(lambda (&rest args) 
+	  (apply function (bin-child bin) (rest args)))
+    (call-next-method)))
 
 
 ;;; Box
@@ -495,6 +521,138 @@ (defbinding entry-completion-delete-action () nil
   (index int))
 
 
+;;; File Chooser
+
+(defmethod initialize-instance ((file-chooser file-chooser) &rest initargs 
+				&key filter filters shortcut-folder 
+				shortcut-folders shortcut-folder-uti
+				shortcut-folder-uris)
+  (declare (ignore filter filters shortcut-folder shortcut-folders 
+		   shortcut-folder-uti shortcut-folder-uris))
+  (prog1
+      (call-next-method)
+    (initial-add file-chooser #'file-chooser-add-filter
+     initargs :filer :filters)
+    (initial-add file-chooser #'file-chooser-add-shortcut-folder
+     initargs :shortcut-folder :shortcut-folders)
+    (initial-add file-chooser #'file-chooser-add-shortcut-folder-uri
+     initargs :shortcut-folder-uri :shortcut-folders-uris)))
+
+
+(defbinding file-chooser-select-filename () boolean
+  (file-chooser file-chooser)
+  (filename string))
+
+(defbinding file-chooser-unselect-filename () nil
+  (file-chooser file-chooser)
+  (filename string))
+
+(defbinding file-chooser-select-all () boolean
+  (file-chooser file-chooser))
+
+(defbinding file-chooser-unselect-all () boolean
+  (file-chooser file-chooser))
+  
+(defbinding file-chooser-get-filenames () (gslist string)
+  (file-chooser file-chooser))
+
+(defbinding file-chooser-select-uri () boolean
+  (file-chooser file-chooser)
+  (uri string))
+
+(defbinding file-chooser-unselect-uri () nil
+  (file-chooser file-chooser)
+  (uri string))
+
+(defbinding file-chooser-get-uris () (gslist string)
+  (file-chooser file-chooser))
+
+(defbinding file-chooser-add-filter () nil
+  (file-chooser file-chooser)
+  (filter file-filter))
+
+(defbinding file-chooser-remove-filter () nil
+  (file-chooser file-chooser)
+  (filter file-filter))
+
+(defbinding file-chooser-list-filters () (gslist file-filter)
+  (file-chooser file-chooser))
+
+(defbinding file-chooser-add-shortcut-folder () boolean
+  (file-chooser file-chooser)
+  (folder string)
+  (nil null))
+
+(defbinding file-chooser-remove-shortcut-folder () nil
+  (file-chooser file-chooser)
+  (folder string)
+  (nil null))
+
+(defbinding file-chooser-list-shortcut-folders () (gslist string)
+  (file-chooser file-chooser))
+
+(defbinding file-chooser-add-shortcut-folder-uri () boolean
+  (file-chooser file-chooser)
+  (uri string)
+  (nil null))
+
+(defbinding file-chooser-remove-shortcut-folder-uri () nil
+  (file-chooser file-chooser)
+  (uri string)
+  (nil null))
+
+(defbinding file-chooser-list-shortcut-folder-uris () (gslist string)
+  (file-chooser file-chooser))
+
+
+;;; File Filter
+
+(defmethod initialize-instance ((file-filter file-filter) &rest initargs 
+				&key mime-type mime-types pattern patterns
+				pixbuf-formats)
+  (declare (ignore mime-type mime-types pattern patterns))
+  (prog1
+      (call-next-method)
+    (when pixbuf-formats
+      #-gtk2.6(warn "Initarg :PIXBUF-FORMATS not supportet in this version of Gtk")
+      #+gtk2.6(file-filter-add-pixbuf-formats file-filter))
+    (initial-add file-filter #'file-filter-add-mime-type
+     initargs :mime-type :mime-types)
+    (initial-add file-filter #'file-filter-add-pattern
+     initargs :pattern :patterns)))
+
+
+(defbinding file-filter-add-mime-type () nil
+  (filter file-filter)
+  (mime-type string))
+
+(defbinding file-filter-add-pattern () nil
+  (filter file-filter)
+  (pattern string))
+
+#+gtk2.6
+(defbinding file-filter-add-pixbuf-formats () nil
+  (filter file-filter)
+  (pattern string))
+
+(def-callback-marshal %file-filter-func (boolean file-filter-info))
+
+(defbinding file-filter-add-custom () nil
+  (filter file-filter)
+  (needed file-filter-flags)
+  ((callback %file-filter-func) pointer)
+  ((register-callback-function function) unsigned-int)
+  ((callback %destroy-user-data) pointer))
+
+(defbinding file-filter-get-needed () file-filter-flags
+  (filter file-filter))
+
+(defbinding file-filter-filter () boolean
+  (filter file-filter)
+  (filter-info file-filter-info))
+
+
+
 ;;; Image
 
 (defbinding image-set-from-file () nil
@@ -517,7 +675,7 @@ (defmethod initialize-instance ((image image) &rest initargs &key pixmap file)
       (image-set-from-file image file)))
    ((call-next-method))))
 
-(defun create-image (source &optional mask)
+(defun create-image-widget (source &optional mask)
   (etypecase source
     (gdk:pixbuf (make-instance 'image :pixbuf source))
     (string (make-instance 'image :stock source))
@@ -530,7 +688,7 @@ (defun create-image (source &optional mask)
 
 (defmethod initialize-instance ((item image-menu-item) &rest initargs &key image)
   (if (and image (not (typep image 'widget)))
-      (apply #'call-next-method item :image (create-image image) initargs) 
+      (apply #'call-next-method item :image (create-image-widget image) initargs) 
     (call-next-method)))
 
 
@@ -538,7 +696,7 @@ (defmethod (setf image-menu-item-image) ((widget widget) (item image-menu-item))
   (setf (slot-value item 'image) widget))
 
 (defmethod (setf image-menu-item-image) (image (item image-menu-item))
-  (setf (image-menu-item-image item) (create-image image)))
+  (setf (image-menu-item-image item) (create-image-widget image)))
 
 
 ;;; Label
@@ -569,16 +727,15 @@ (defbinding %radio-button-set-group () nil
   (radio-button radio-button)
   (group pointer))
 
-(defun radio-button-add-to-group (button1 button2)
+(defmethod add-to-radio-group ((button1 radio-button) (button2 radio-button))
   "Add BUTTON1 to the group which BUTTON2 belongs to."
   (%radio-button-set-group button1 (%radio-button-get-group button2)))
 
-
 (defmethod initialize-instance ((button radio-button) &key group)
   (prog1
       (call-next-method)
     (when group
-      (radio-button-add-to-group button group))))
+      (add-to-radio-group button group))))
 
 
 ;;; Item
@@ -702,7 +859,7 @@ (defbinding %radio-menu-item-set-group () nil
   (radio-menu-item radio-menu-item)
   (group pointer))
 
-(defun radio-menu-item-add-to-group (item1 item2)
+(defmethod add-to-radio-group ((item1 radio-menu-item) (item2 radio-menu-item))
   "Add ITEM1 to the group which ITEM2 belongs to."
   (%radio-menu-item-set-group item1 (%radio-menu-item-get-group item2)))
 
@@ -710,7 +867,8 @@ (defmethod initialize-instance ((item radio-menu-item) &key group)
   (prog1
       (call-next-method)
     (when group
-      (radio-menu-item-add-to-group item group))))
+      (add-to-radio-group item group))))
+
   
 
 ;;; Radio tool button
@@ -722,16 +880,29 @@ (defbinding %radio-tool-button-set-group () nil
   (radio-tool-button radio-tool-button)
   (group pointer))
 
-(defun radio-tool-button-add-to-group (button1 button2)
+(defmethod add-to-radio-group ((button1 radio-tool-button) (button2 radio-tool-button))
   "Add BUTTON1 to the group which BUTTON2 belongs to."
   (%radio-tool-button-set-group button1 (%radio-tool-button-get-group button2)))
 
+(defmethod add-activate-callback ((widget widget) function &key object after)
+  (if object
+      (signal-connect widget 'clicked
+       #'(lambda (object)
+	   (when (slot-value widget 'active)
+	     (funcall function object (slot-value widget 'value))))
+       :object object :after after)
+    (signal-connect widget 'clicked 
+     #'(lambda ()
+	 (when (slot-value widget 'active)
+	   (funcall function (slot-value widget 'value))))
+     :after after)))
 
 (defmethod initialize-instance ((button radio-tool-button) &key group)
   (prog1
       (call-next-method)
     (when group
-      (radio-tool-button-add-to-group button group))))
+      (add-to-radio-group button group))))
+
 
 
 ;;; Toggle button
@@ -1071,20 +1242,15 @@ (defbinding fixed-move () nil
 
 ;;; Notebook
 
-(defun %notebook-position (notebook page)
+(defun %ensure-notebook-position (notebook page)
   (etypecase page
-    (int page)
-    (keyword (case page
-	       (:first 0)
-	       (:last -1)
-	       (t (error "Invalid position keyword: ~A" page))))
+    (position page)
     (widget (notebook-page-num notebook page t))))
 
-(defun %notebook-child (notebook position)
+(defun %ensure-notebook-child (notebook position)
   (typecase position
      (widget position)
-     (t (notebook-nth-page-child notebook position))))
-
+     (t (notebook-get-nth-page notebook position))))
 
 (defbinding (notebook-insert "gtk_notebook_insert_page_menu")
     (notebook position child tab-label &optional menu-label) nil
@@ -1096,7 +1262,7 @@ (defbinding (notebook-insert "gtk_notebook_insert_page_menu")
   ((if (stringp menu-label)
        (make-instance 'label :label menu-label)
      menu-label) (or null widget))
-  ((%notebook-position notebook position) int))
+  ((%ensure-notebook-position notebook position) position))
 
 (defun notebook-append (notebook child tab-label &optional menu-label)
   (notebook-insert notebook :last child tab-label menu-label))
@@ -1106,7 +1272,7 @@ (defun notebook-prepend (notebook child tab-label &optional menu-label)
   
 (defbinding notebook-remove-page (notebook page) nil
   (notebook notebook)
-  ((%notebook-position notebook page) int))
+  ((%ensure-notebook-position notebook page) position))
 
 (defbinding %notebook-page-num () int
   (notebook notebook)
@@ -1116,7 +1282,7 @@ (defun notebook-page-num (notebook child &optional error-p)
   (let ((page-num (%notebook-page-num notebook child)))
     (if (= page-num -1)
 	(when error-p
-	  (error "~A is not a child of ~A" child notebook))
+	  (error "~A is not a page in ~A" child notebook))
       page-num)))
 
 (defbinding notebook-next-page () nil
@@ -1136,46 +1302,26 @@ (defbinding notebook-popup-enable () nil
 (defbinding notebook-popup-disable () nil
   (notebook notebook))
 
-(defbinding (notebook-nth-page-child "gtk_notebook_get_nth_page")
-    (notebook page) widget
+(defbinding notebook-get-nth-page () widget
   (notebook notebook)
-  ((case page
-     (:first 0)
-     (:last -1)
-     (t page)) int))
+  (page position))
 
-
-(defbinding %notebook-get-current-page () int
-  (notebook notebook))
-
-(defun notebook-current-page-num (notebook)
-  (let ((num (%notebook-get-current-page notebook)))
-    (when (>= num 0)
-      num)))
-
-(defun notebook-current-page (notebook)
-  (let ((page-num (notebook-current-page-num notebook)))
-    (when page-num
-      (notebook-nth-page-child notebook page-num))))
-
-(defbinding  %notebook-set-current-page () nil
-  (notebook notebook)
-  (page-num int))
+(defun %notebook-current-page (notebook)
+  (when (slot-boundp notebook 'current-page-num)
+    (notebook-get-nth-page notebook (notebook-current-page-num notebook))))
 
 (defun (setf notebook-current-page) (page notebook)
-  (%notebook-set-current-page notebook (%notebook-position notebook page))
-  page)
-
+  (setf (notebook-current-page notebook) (notebook-page-num notebook page)))
 
 (defbinding (notebook-tab-label "gtk_notebook_get_tab_label")
     (notebook page) widget
   (notebook notebook)
-  ((%notebook-child notebook page) widget))
+  ((%ensure-notebook-child notebook page) widget))
 
 (defbinding (notebook-tab-label-text "gtk_notebook_get_tab_label_text")
     (notebook page) (copy-of string)
   (notebook notebook)
-  ((%notebook-child notebook page) widget))
+  ((%ensure-notebook-child notebook page) widget))
 
 (defbinding %notebook-set-tab-label () nil
   (notebook notebook)
@@ -1186,19 +1332,19 @@ (defun (setf notebook-tab-label) (tab-label notebook page)
   (let ((widget (if (stringp tab-label)
 		    (make-instance 'label :label tab-label)
 		  tab-label)))
-    (%notebook-set-tab-label notebook (%notebook-child notebook page) widget)
+    (%notebook-set-tab-label notebook (%ensure-notebook-child notebook page) widget)
     widget))
 
 
 (defbinding (notebook-menu-label "gtk_notebook_get_menu_label")
     (notebook page) widget
   (notebook notebook)
-  ((%notebook-child notebook page) widget))
+  ((%ensure-notebook-child notebook page) widget))
 
 (defbinding (notebook-menu-label-text "gtk_notebook_get_menu_label_text")
     (notebook page) (copy-of string)
   (notebook notebook)
-  ((%notebook-child notebook page) widget))
+  ((%ensure-notebook-child notebook page) widget))
 
 (defbinding %notebook-set-menu-label () nil
   (notebook notebook)
@@ -1209,7 +1355,7 @@ (defun (setf notebook-menu-label) (menu-label notebook page)
   (let ((widget (if (stringp menu-label)
 		    (make-instance 'label :label menu-label)
 		  menu-label)))
-    (%notebook-set-menu-label notebook (%notebook-child notebook page) widget)
+    (%notebook-set-menu-label notebook (%ensure-notebook-child notebook page) widget)
     widget))
 
 
@@ -1249,16 +1395,25 @@ (defbinding paned-pack2 () nil
 
 (defbinding layout-put () nil
   (layout layout)
-  (widget widget)
+  (child widget)
   (x int)
   (y int))
 
 (defbinding layout-move () nil
   (layout layout)
-  (widget widget)
+  (child widget)
   (x int)
   (y int))
 
+(defbinding layout-set-size () nil
+  (layout layout)
+  (width unsigned-int)
+  (height unsigned-int))
+
+(defbinding layout-get-size () nil
+  (layout layout)
+  (width unsigned-int :out)
+  (height unsigned-int :out))
 
 
 ;;; Menu shell
@@ -1475,119 +1630,83 @@ (defun table-col-spacing (table &optional col)
 
 ;;; Toolbar
 
-(defbinding %toolbar-insert-element () widget
-  (toolbar toolbar)
-  (type toolbar-child-type)
-  (widget (or null widget))
-  (text string)
-  (tooltip-text string)
-  (tooltip-private-text string)
-  (icon (or null widget))
-  (nil null)
-  (nil null)
-  (position int))
+(defmethod initialize-instance ((toolbar toolbar) &rest initargs &key tooltips)
+  (if (eq tooltips t)
+      (apply #'call-next-method toolbar
+       :tooltips (make-instance 'tooltips) initargs)
+    (call-next-method)))
 
-(defbinding %toolbar-insert-stock () widget
+(defbinding %toolbar-insert () nil
   (toolbar toolbar)
-  (stock-id string)
-  (tooltip-text string)
-  (tooltip-private-text string)
-  (nil null)
-  (nil null)
-  (position int))
-
-(defun toolbar-insert (toolbar position element
-		       &key tooltip-text tooltip-private-text
-		       type icon group callback object)
-  (let* ((numpos (case position
-		   (:first -1)
-		   (:last 0)
-		   (t position)))
-	 (widget
-	  (cond
-	   ((or
-	     (eq type :space)
-	     (and (not type) (eq element :space)))
-	    (%toolbar-insert-element
-	     toolbar :space nil nil
-	     tooltip-text tooltip-private-text nil numpos))
-	   ((or
-	     (eq type :widget)
-	     (and (not type) (typep element 'widget)))
-	    (%toolbar-insert-element
-	     toolbar :widget element nil
-	     tooltip-text tooltip-private-text nil numpos))
-	   ((or
-	     (eq type :stock)
-	     (and
-	      (not type)
-	      (typep element 'string)
-	      (stock-lookup element)))
-	    (%toolbar-insert-stock
-	     toolbar element tooltip-text tooltip-private-text numpos))
-	   ((typep element 'string)
-	    (%toolbar-insert-element
-	     toolbar (or type :button) (when (eq type :radio-button) group)
-	     element tooltip-text tooltip-private-text 
-	     (etypecase icon
-	       (null nil)
-	       (widget icon)
-	       (string (make-instance 'image :stock icon))
-	       (pathname (make-instance 'image :file icon))
-	       ((or list vector)
-		(make-instance 'image 
-		 :pixmap icon ; :icon-size (toolbar-icon-size toolbar)
-		 )))
-	     numpos))
-	   ((error "Invalid element type: ~A" element)))))
-    (when callback
-      (signal-connect widget 'clicked callback :object object))
-    widget))
-
-(defun toolbar-append (toolbar element &key tooltip-text tooltip-private-text
-		       type icon group callback object)
-  (toolbar-insert
-   toolbar :first element :type type :icon icon :group group
-   :tooltip-text tooltip-text :tooltip-private-text tooltip-private-text
-   :callback callback :object object))
+  (tool-item tool-item)
+  (position position))
 
-(defun toolbar-prepend (toolbar element &key tooltip-text tooltip-private-text
-			type icon group callback object)
-  (toolbar-insert
-   toolbar :last element :type type :icon icon :group group
-   :tooltip-text tooltip-text :tooltip-private-text tooltip-private-text
-   :callback callback :object object))
+(defun toolbar-insert (toolbar tool-item &optional (position :end))
+  (%toolbar-insert toolbar tool-item position)
+  (%tool-item-update-tooltips tool-item))
 
+(defbinding toolbar-get-item-index () int
+  (toolbar toolbar)
+  (item tool-item))
 
-(defun toolbar-insert-space (toolbar position)
-  (toolbar-insert toolbar position :space))
+(defbinding toolbar-get-nth-item () tool-item
+  (toolbar toolbar)
+  (n int))
 
-(defun toolbar-append-space (toolbar)
-  (toolbar-append toolbar :space))
+(defbinding toolbar-get-drop-index () int
+  (toolbar toolbar)
+  (x int) (y int))
 
-(defun toolbar-prepend-space (toolbar)
-  (toolbar-prepend toolbar :space))
+(defbinding toolbar-set-drop-highlight-item () nil
+  (toolbar toolbar)
+  (tool-item tool-item)
+  (index int))
 
 
-(defun toolbar-enable-tooltips (toolbar)
-  (setf (toolbar-tooltips-p toolbar) t))
+;;; Tool button
 
-(defun toolbar-disable-tooltips (toolbar)
-  (setf (toolbar-tooltips-p toolbar) nil))
+(defmethod initialize-instance ((button tool-button) &rest initargs &key icon)
+  (if (and icon (not (typep icon 'widget)))
+      (apply #'call-next-method button :icon (create-image-widget icon) initargs)
+    (call-next-method)))
 
 
-(defbinding toolbar-remove-space () nil
-  (toolbar toolbar)
-  (position int))
+;;; Tool item
 
-(defbinding toolbar-unset-icon-size () nil
-  (toolbar toolbar))
+(defbinding tool-item-set-tooltip () nil
+  (tool-item tool-item)
+  (tooltips tooltips)
+  (tip-text string)
+  (tip-private string))
 
-(defbinding toolbar-unset-style () nil
-  (toolbar toolbar))
 
+(defun %tool-item-update-tooltips (tool-item)
+  (when (and 
+	 (slot-boundp tool-item 'parent)
+	 (or 
+	  (user-data-p tool-item 'tip-text)
+	  (user-data-p tool-item 'tip-private)))
+    (tool-item-set-tooltip
+     tool-item (toolbar-tooltips (widget-parent tool-item))
+     (or (user-data tool-item 'tip-text) "")
+     (or (user-data tool-item 'tip-private) ""))))
+
+(defmethod (setf tool-item-tip-text) ((tip-text string) (tool-item tool-item))
+  (setf (user-data tool-item 'tip-text) tip-text)
+  (%tool-item-update-tooltips tool-item)
+  tip-text)
+
+(defmethod (setf tool-item-tip-private) ((tip-private string) (tool-item tool-item))
+  (setf (user-data tool-item 'tip-private) tip-private)
+  (%tool-item-update-tooltips tool-item)
+  tip-private)
+
+(defmethod container-add ((toolbar toolbar) (tool-item tool-item) &rest args)
+  (declare (ignore args))
+  (prog1
+      (call-next-method)
+    (%tool-item-update-tooltips tool-item)))
 
-;;; Tool item
 
 (defbinding tool-item-retrieve-proxy-menu-item () widget
   (tool-item tool-item))
@@ -1627,7 +1746,7 @@ (defbinding editable-insert-text (editable text &optional (position 0)) nil
   (editable editable)
   (text string)
   ((length text) int)
-  (position editable-position :in-out))
+  (position position-type :in-out))
 
 (defun editable-append-text (editable text)
   (editable-insert-text editable text nil))
@@ -1708,11 +1827,12 @@ (defbinding ruler-set-range () nil
   (position single-float)
   (max-size single-float))
 
-(defbinding ruler-draw-ticks () nil
-  (ruler ruler))
-
-(defbinding ruler-draw-pos () nil
-  (ruler ruler))
+(defbinding ruler-get-range () nil
+  (ruler ruler)
+  (lower single-float :out)
+  (upper single-float :out)
+  (position single-float :out)
+  (max-size single-float :out))
 
 
 
@@ -1755,9 +1875,10 @@ (defbinding range-set-increments () nil
 
 ;;; Scale
 
-; (defbinding scale-draw-value () nil
-;   (scale scale))
-
+(defbinding scale-get-layout-offsets () nil
+  (scale scale)
+  (x int :out)
+  (y int :out))
 
 
 ;;; Progress bar