X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/55212af123daea1d86d31da21cc1bee77651fb81..8ef4708822a3efcab209815d66ae2433d93a6433:/gtk/gtk.lisp

diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp
index aaa9d45..6a95c27 100644
--- a/gtk/gtk.lisp
+++ b/gtk/gtk.lisp
@@ -20,7 +20,7 @@
 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
-;; $Id: gtk.lisp,v 1.42 2005/04/23 16:48:51 espen Exp $
+;; $Id: gtk.lisp,v 1.56 2006/02/26 21:19:02 espen Exp $
 
 
 (in-package "GTK")
@@ -44,7 +44,8 @@
 	(format nil "Gtk+ v~A.~A" major minor) 
       (format nil "Gtk+ v~A.~A.~A" major minor micro))))
 
-(defbinding get-default-language () (copy-of pango:language))
+(defun clg-version ()
+  "clg 0.91 version")
 
 
 ;;;; Initalization
@@ -56,6 +57,11 @@
 
 (defun clg-init (&optional display)
   "Initializes the system and starts the event handling"
+  #+sbcl(when (and 
+	       (find-package "SWANK")
+	       (eq (symbol-value (find-symbol "*COMMUNICATION-STYLE*" "SWANK")) :spawn))
+	  (error "When running clg in Slime the communication style :spawn can not be used. See the README file and <http://common-lisp.net/project/slime/doc/html/slime_45.html> for more information."))
+
   (unless (gdk:display-get-default)
     (gdk:gdk-init)
     (unless (gtk-init)
@@ -78,23 +84,25 @@
 (defbinding grab-remove () nil
   (widget widget))
 
+(defbinding get-default-language () (copy-of pango:language))
+
 
 ;;; About dialog
 
 #+gtk2.6
 (progn
-  (def-callback-marshal %about-dialog-activate-link-func 
-    (nil (dialog about-dialog) (link (copy-of string))))
+  (define-callback-marshal %about-dialog-activate-link-callback nil
+    (about-dialog (link string)))
 
   (defbinding about-dialog-set-email-hook (function) nil
-    ((callback %about-dialog-activate-link-func) pointer)
+    (%about-dialog-activate-link-callback callback)
     ((register-callback-function function) unsigned-int)
-    ((callback user-data-destroy-func) pointer))
+    (user-data-destroy-callback callback))
   
   (defbinding about-dialog-set-url-hook (function) nil
-    ((callback %about-dialog-activate-link-func) pointer)
+    (%about-dialog-activate-link-callback callback)
     ((register-callback-function function) unsigned-int)
-    ((callback user-data-destroy-func) pointer)))
+    (user-data-destroy-callback callback)))
 
 
 ;;; Acccel group
@@ -107,7 +115,7 @@
   (gclosure gclosure))
 
 (defun accel-group-connect (group accelerator function &optional flags)
-  (multiple-value-bind (key modifiers) (accelerator-parse accelerator)
+  (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
     (let ((gclosure (make-callback-closure function)))
       (%accel-group-connect group key modifiers flags gclosure)
       gclosure)))
@@ -130,22 +138,45 @@
   (etypecase accelerator
     (gclosure (%accel-group-disconnect group accelerator))
     (string 
-     (multiple-value-bind (key modifiers) (accelerator-parse accelerator)
+     (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
        (%accel-group-disconnect-key group key modifiers)))))
 
+(defbinding %accel-group-query () (copy-of (vector (inlined accel-group-entry) n))
+  (accel-group accel-group)
+  (key unsigned-int)
+  (modifiers gdk:modifier-type)
+  (n int :out))
+
+(defun accel-group-query (accel-group accelerator)
+  (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
+    (%accel-group-query accel-group key modifiers)))
+
+(defbinding %accel-group-activate () boolean
+  (accel-group accel-group)
+  (acceleratable gobject)
+  (key unsigned-int)
+  (modifiers gdk:modifier-type))
+
+(defun accel-group-activate (accel-group acceleratable accelerator)
+  (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
+    (%accel-group-activate accel-group acceleratable key modifiers)))
+
 (defbinding accel-group-lock () nil
   (accel-group accel-group))
 
 (defbinding accel-group-unlock () nil
   (accel-group accel-group))
 
+(defbinding accel-group-from-accel-closure () accel-group
+  (closure gclosure))
+
 (defbinding %accel-groups-activate () boolean
   (object gobject)
   (key unsigned-int)
   (modifiers gdk:modifier-type))
 
 (defun accel-groups-activate (object accelerator)
-  (multiple-value-bind (key modifiers) (accelerator-parse accelerator)
+  (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
     (%accel-groups-activate object key modifiers)))
 
 (defbinding accel-groups-from-object () (gslist accel-groups)
@@ -160,12 +191,35 @@
   (key unsigned-int :out)
   (modifiers gdk:modifier-type :out))
 
-(defun accelerator-parse (accelerator)
+(defgeneric parse-accelerator (accelerator))
+
+(defmethod parse-accelerator ((accelerator string))
   (multiple-value-bind (key modifiers) (%accelerator-parse accelerator)
     (if (zerop key)
 	(error "Invalid accelerator: ~A" accelerator)
       (values key modifiers))))
 
+(defmethod parse-accelerator ((accelerator cons))
+  (destructuring-bind (key modifiers) accelerator
+    (values
+     (etypecase key
+       (integer key)
+       (string
+	(or 
+	 (gdk:keyval-from-name key)
+	 (error "Invalid key name: ~A" key)))
+       (character (parse-accelerator key)))
+     modifiers)))
+
+(defmethod parse-accelerator ((key integer))
+  key)
+
+(defmethod parse-accelerator ((key character))
+  (or
+   (gdk:keyval-from-name (string key))
+   (error "Invalid key name: ~A" key)))
+
+
 (defbinding accelerator-name () string
   (key unsigned-int)
   (modifiers gdk:modifier-type))
@@ -186,6 +240,9 @@
 
 ;;; Acccel label
 
+(defbinding accel-label-get-accel-width () unsigned-int
+  (accel-label accel-label))
+
 (defbinding accel-label-refetch () boolean
   (accel-label accel-label))
 
@@ -193,7 +250,7 @@
 
 ;;; Accel map
 
-;(defbinding (accel-map-init "_gtk_accel_map_init") () nil)
+(defbinding (accel-map-init "_gtk_accel_map_init") () nil)
 
 (defbinding %accel-map-add-entry () nil
   (path string)
@@ -201,12 +258,20 @@
   (modifiers gdk:modifier-type))
 
 (defun accel-map-add-entry (path accelerator)
-  (multiple-value-bind (key modifiers) (accelerator-parse accelerator)
+  (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
     (%accel-map-add-entry path key modifiers)))
 
-(defbinding accel-map-lookup-entry () boolean
+(defbinding %accel-map-lookup-entry () boolean
   (path string)
-  (key pointer)) ;accel-key))
+  ((make-instance 'accel-key) accel-key :return))
+
+(defun accel-map-lookup-entry (path)
+  (multiple-value-bind (found-p accel-key) (%accel-map-lookup-entry path)
+    (when found-p
+      (values 
+       (slot-value accel-key 'key)
+       (slot-value accel-key 'modifiers)
+       (slot-value accel-key 'flags)))))
 
 (defbinding %accel-map-change-entry () boolean
   (path string)
@@ -215,7 +280,7 @@
   (replace boolean))
 
 (defun accel-map-change-entry (path accelerator &optional replace)
-  (multiple-value-bind (key modifiers) (accelerator-parse accelerator)
+  (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
     (%accel-map-change-entry path key modifiers replace)))
 
 (defbinding accel-map-load () nil
@@ -224,6 +289,27 @@
 (defbinding accel-map-save () nil
   (filename pathname))
 
+(define-callback-marshal %accel-map-foreach-callback nil
+  ((accel-path string) (key unsigned-int) 
+   (modifiers gdk:modifier-type) (changed boolean)) :callback-id :first)
+
+(defbinding %accel-map-foreach (callback-id) nil
+  (callback-id unsigned-int)
+  (%accel-map-foreach-callback callback))
+
+(defbinding %accel-map-foreach-unfiltered (callback-id) nil
+  (callback-id unsigned-int)
+  (%accel-map-foreach-callback callback))
+
+(defun accel-map-foreach (function &optional (filter-p t))
+  (with-callback-function (id function)
+    (if filter-p			  
+	(%accel-map-foreach id)
+      (%accel-map-foreach-unfiltered id))))
+
+(defbinding accel-map-add-filter () nil
+  (filter string))
+
 (defbinding accel-map-get () accel-map)
 
 (defbinding accel-map-lock-path () nil
@@ -234,7 +320,7 @@
 
 
 
-;;; Accessible
+;;; Accessibility
 
 (defbinding accessible-connect-widget-destroyed () nil
   (accessible accessible))
@@ -609,8 +695,8 @@
 
 #+gtk2.6
 (defbinding (dialog-set-alternative-button-order 
-	     "gtk_dialog_set_alternative_button_order_from_array") 
-    (dialog new-order)
+	     "gtk_dialog_set_alternative_button_order_from_array")
+    (dialog new-order) nil
   (dialog dialog)
   ((length new-order) int)
   ((map 'vector #'(lambda (response)
@@ -618,6 +704,16 @@
 	new-order) (vector int)))
 
 
+#+gtk2.8
+(progn
+  (defbinding %dialog-get-response-for-widget () int
+    (dialog dialog)
+    (widget widget))
+
+  (defun dialog-get-response-for-widget (dialog widget)
+    (dialog-find-response dialog (dialog-get-response-for-widget dialog widget))))
+
+
 (defmethod container-add ((dialog dialog) (child widget) &rest args)
   (apply #'container-add (dialog-vbox dialog) child args))
 
@@ -650,14 +746,14 @@
 
 ;;; Entry Completion
 
-(def-callback-marshal %entry-completion-match-func
-    (boolean entry-completion string (copy-of tree-iter)))
+(define-callback-marshal %entry-completion-match-callback boolean 
+  (entry-completion string tree-iter))
 
 (defbinding entry-completion-set-match-func (completion function) nil
   (completion entry-completion)
-  ((callback %entry-completion-match-func) pointer)
+  (%entry-completion-match-callback callback)
   ((register-callback-function function) unsigned-int)
-  ((callback user-data-destroy-func) pointer))
+  (user-data-destroy-callback callback))
 
 (defbinding entry-completion-complete () nil
   (completion entry-completion))
@@ -794,14 +890,14 @@
 (defbinding file-filter-add-pixbuf-formats () nil
   (filter file-filter))
 
-(def-callback-marshal %file-filter-func (boolean file-filter-info))
+(define-callback-marshal %file-filter-callback boolean (file-filter-info))
 
 (defbinding file-filter-add-custom (filter needed function) nil
   (filter file-filter)
   (needed file-filter-flags)
-  ((callback %file-filter-func) pointer)
+  (%file-filter-callback callback)
   ((register-callback-function function) unsigned-int)
-  ((callback user-data-destroy-func) pointer))
+  (user-data-destroy-callback callback))
 
 (defbinding file-filter-get-needed () file-filter-flags
   (filter file-filter))
@@ -842,6 +938,11 @@
     ((or list vector) (make-instance 'image :pixmap source))
     (gdk:pixmap (make-instance 'image :pixmap source :mask mask))))
 
+#+gtk2.8
+(defbinding image-clear () nil
+  (image image))
+
+
 
 ;;; Image menu item
 
@@ -993,13 +1094,14 @@
 
 ;;; Message dialog
 
-(defmethod initialize-instance ((dialog message-dialog)
-				&key (message-type :info) (buttons :close)
-				flags text #+gtk 2.6 secondary-text 
-				transient-parent)
-  (setf 
-   (slot-value dialog 'location)
-   (%message-dialog-new transient-parent flags message-type buttons))
+(defmethod allocate-foreign ((dialog message-dialog) &key (message-type :info)
+			     (buttons :close) flags transient-parent)
+  (%message-dialog-new transient-parent flags message-type buttons))
+
+
+(defmethod shared-initialize ((dialog message-dialog) names
+			      &key text #+gtk 2.6 secondary-text)
+  (declare (ignore names))
   (when text
     (message-dialog-set-markup dialog text))
   #+gtk2.6
@@ -1100,6 +1202,16 @@
     (initial-add window #'window-add-accel-group 
      initargs :accel-group :accel-groups)))
 
+#-debug-ref-counting
+(defmethod print-object ((window window) stream)
+  (if (and 
+       (proxy-valid-p window) 
+       (slot-boundp window 'title) 
+       (not (zerop (length (window-title window)))))
+      (print-unreadable-object (window stream :type t :identity nil)
+        (format stream "~S at 0x~X" 
+	 (window-title window) (sap-int (foreign-location window))))
+    (call-next-method)))
 
 (defbinding window-set-wmclass () nil
   (window window)
@@ -1187,9 +1299,24 @@
   (window window)
   (event gdk:key-event))
 
+#-gtk2.8
 (defbinding window-present () nil
   (window window))
 
+#+gtk2.8
+(progn
+  (defbinding %window-present () nil
+    (window window))
+
+  (defbinding %window-present-with-time () nil
+    (window window)
+    (timespamp unsigned-int))
+
+  (defun window-present (window &optional timestamp)
+    (if timestamp
+	(%window-present-with-time window timestamp)
+      (%window-present window))))
+
 (defbinding window-iconify () nil
   (window window))
 
@@ -1253,7 +1380,7 @@
   (window window)
   (left int :out) (top int :out) (rigth int :out) (bottom int :out))
 
-(defbinding %window-get-icon-list () (glist gdk:pixbuf)
+(defbinding %window-get-icon-list () (glist (copy-of gdk:pixbuf))
   (window window))
 
 (defbinding window-get-position () nil
@@ -1473,7 +1600,7 @@
 (defbinding notebook-reorder-child (notebook child position) nil
   (notebook notebook)
   (child widget)
-  ((%notebook-position notebook position) int))
+  ((%ensure-notebook-position notebook position) int))
 
 (defbinding notebook-popup-enable () nil
   (notebook notebook))
@@ -1540,7 +1667,7 @@
 
 (defbinding notebook-query-tab-label-packing (notebook page) nil
   (notebook notebook)
-  ((%notebook-child notebook page) widget)
+  ((%ensure-notebook-child notebook page) widget)
   (expand boolean :out)
   (fill boolean :out)
   (pack-type pack-type :out))
@@ -1548,7 +1675,7 @@
 (defbinding notebook-set-tab-label-packing
     (notebook page expand fill pack-type) nil
   (notebook notebook)
-  ((%notebook-child notebook page) widget)
+  ((%ensure-notebook-child notebook page) widget)
   (expand boolean)
   (fill boolean)
   (pack-type pack-type))
@@ -1659,13 +1786,14 @@
   (top-attach unsigned-int)
   (bottom-attach unsigned-int))
 
-(def-callback-marshal %menu-position-func (nil (menu menu) (x int) (y int) (push-in boolean)))
+(define-callback-marshal %menu-position-callback nil 
+  (menu (x int) (y int) (push-in boolean)))
 
 (defbinding %menu-popup () nil
   (menu menu)
   (parent-menu-shell (or null menu-shell))
   (parent-menu-item (or null menu-item))
-  (callback-func (or null pointer))
+  (callback (or null callback))
   (callback-id unsigned-int)
   (button unsigned-int)
   (activate-time (unsigned 32)))
@@ -1676,7 +1804,7 @@
       (with-callback-function (id callback)
 	(%menu-popup 
 	 menu parent-menu-shell parent-menu-item 
-	 (callback %menu-position-func) id button activate-time))
+	 %menu-position-callback id button activate-time))
     (%menu-popup
      menu parent-menu-shell parent-menu-item nil 0 button activate-time)))
  
@@ -1704,13 +1832,13 @@
   (%menu-set-active menu (%menu-position menu child))
   child)
   
-(defcallback %menu-detach-func (nil (widget widget) (menu menu))
+(define-callback %menu-detach-callback nil ((widget widget) (menu menu))
   (funcall (object-data menu 'detach-func) widget menu))
 
-(defbinding %menu-attach-to-widget () nil
+(defbinding %menu-attach-to-widget (menu widget) nil
   (menu menu)
   (widget widget)
-  ((callback %menu-detach-func) pointer))
+  (%menu-detach-callback callback))
 
 (defun menu-attach-to-widget (menu widget function)
   (setf (object-data menu 'detach-func) function)
@@ -2117,13 +2245,22 @@
   (location pointer))
 
 (defun stock-lookup (stock-id)
-  (let ((location 
-	 (allocate-memory (proxy-instance-size (find-class 'stock-item)))))
-    (unwind-protect
-	(when (%stock-lookup stock-id location)
-	  (ensure-proxy-instance 'stock-item (%stock-item-copy location)))
-	(deallocate-memory location))))
+  (with-allocated-memory (stock-item (foreign-size (find-class 'stock-item)))
+    (when (%stock-lookup stock-id stock-item)
+      (ensure-proxy-instance 'stock-item (%stock-item-copy stock-item)))))
+
+#+gtk2.8
+(progn
+  (define-callback-marshal %stock-translate-callback string ((path string)))
 
+  (defbinding (stock-set-translate-function "gtk_stock_set_translate_func") 
+      (domain function) nil
+    (domain string)
+    (%stock-translate-callback callback)
+    ((register-callback-function function) unsigned-int)
+    (user-data-destroy-callback callback)))
+
+  
 
 ;;; Tooltips
 
@@ -2156,7 +2293,7 @@
   (current-widget widget :out))
 
 
-;;; Rc
+;;; Resource Files
 
 (defbinding rc-add-default-file (filename) nil
   ((namestring (truename filename)) string))