[mcclim-cvs] CVS mcclim/Backends/gtkairo
dlichteblau
dlichteblau at common-lisp.net
Sun Nov 12 20:12:19 UTC 2006
Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo
In directory clnet:/tmp/cvs-serv17778/Backends/gtkairo
Modified Files:
event.lisp frame-manager.lisp gadgets.lisp gtk-ffi.lisp
Log Message:
Native list panes.
* event.lisp (VIEW-SELECTION-CALLBACK): New.
* frame-manager.lisp ((MAKE-PANE-2 GENERIC-LIST-PANE)): New.
* gadgets.lisp (GTK-LIST, LIST-SELECTION-EVENT, +G-TYPE-STRING+,
UNINSTALL-SCROLLER-PANE, LIST-PANE-SELECTION,
(REALIZE-NATIVE-WIDGET GTK-LIST), GTK-LIST-SELECT-VALUE,
GTK-LIST-RESET-SELECTION, ((SETF GADGET-VALUE) GTK-LIST),
(CONNECT-NATIVE-SIGNALS GTK-LIST), *LIST-SELECTION-RESULT*,
LIST-SELECTION-CALLBACK, (HANDLE-EVENT LIST-SELECTION-EVENT)): New.
* gtk-ffi.lisp (gtktreeiter, gvalue): New structs.
(gtkselectionmode): New enum. (gtk_tree_view_new_with_model,
gtk_list_store_newv, gtk_list_store_append,
gtk_list_store_set_value, g_value_init, g_value_set_string,
gtk_cell_renderer_text_new, gtk_tree_view_column_new,
gtk_tree_view_column_get_widget, gtk_tree_view_column_set_widget,
gtk_tree_view_column_pack_start, gtk_tree_view_insert_column,
gtk_tree_view_column_add_attribute,
gtk_tree_view_column_set_title, gtk_scrolled_window_new,
gtk_tree_view_get_hadjustment, gtk_tree_view_get_vadjustment,
gtk_tree_view_get_selection, gtk_tree_selection_set_mode,
gtk_tree_selection_unselect_all, gtk_tree_selection_select_path,
gtk_tree_path_new_from_indices, gtk_tree_path_free,
gtk_tree_selection_set_select_function, gtk_tree_path_get_indices,
gtk_tree_selection_selected_foreach): New declarations.
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/12 13:46:08 1.12
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/12 20:12:19 1.13
@@ -411,3 +411,15 @@
(remhash data *later-table*)
(funcall fun))
0)
+
+(cffi:defcallback view-selection-callback :int
+ ((selection :pointer)
+ (model :pointer)
+ (path :pointer)
+ (isselected :int)
+ (data :pointer))
+ selection model path isselected
+ (when (boundp '*port*) ;kludge
+ (let ((sheet (widget->sheet data *port*)))
+ (enqueue (make-instance 'list-selection-event :sheet sheet))))
+ 1)
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/11/12 13:46:08 1.5
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/11/12 20:12:19 1.6
@@ -93,6 +93,9 @@
((:some-of nil) 'gtk-check-button))
initargs))
+(defmethod make-pane-2 ((type (eql 'clim:generic-list-pane)) &rest initargs)
+ (apply #'make-instance 'gtk-list initargs))
+
(defmethod adopt-frame :after
((fm gtkairo-frame-manager) (frame application-frame))
())
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/12 13:46:08 1.7
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/12 20:12:19 1.8
@@ -35,6 +35,8 @@
(defclass context-menu-cancelled-event (gadget-event) ())
+(defclass list-selection-event (gadget-event) ())
+
;;;; Classes
@@ -45,6 +47,10 @@
(defclass gtk-check-button (native-widget-mixin toggle-button) ())
(defclass gtk-radio-button (native-widget-mixin toggle-button) ())
+(defclass gtk-list (native-widget-mixin list-pane climi::meta-list-pane)
+ ((title :initarg :title :initform "" :accessor list-pane-title)
+ (tree-view :accessor list-pane-tree-view)))
+
(defclass native-slider (native-widget-mixin climi::slider-gadget)
((climi::show-value-p :type boolean
:initform nil
@@ -80,6 +86,104 @@
(gtk_toggle_button_set_active widget (if (gadget-value sheet) 1 0))
widget))
+(defconstant +g-type-string+ (ash 16 2))
+
+(defun uninstall-scroller-pane (pane)
+ (with-slots (climi::scroll-bar
+ climi::vscrollbar climi::hscrollbar
+ climi::x-spacing climi::y-spacing)
+ pane
+ (setf scroll-bar nil)
+ (when climi::vscrollbar
+ (sheet-disown-child pane climi::vscrollbar)
+ (setf climi::vscrollbar nil))
+ (when climi::hscrollbar
+ (sheet-disown-child pane climi::hscrollbar)
+ (setf climi::hscrollbar nil))
+ (setf climi::x-spacing 0)
+ (setf climi::y-spacing 0)
+ (let ((r (sheet-region pane)))
+ (allocate-space pane
+ (bounding-rectangle-width r)
+ (bounding-rectangle-height r)))))
+
+(defun list-pane-selection (sheet)
+ (gtk_tree_view_get_selection (list-pane-tree-view sheet)))
+
+(defmethod realize-native-widget ((sheet gtk-list))
+ (cffi:with-foreign-object (types :ulong 2)
+ (setf (cffi:mem-aref types :long 0) +g-type-string+)
+ (setf (cffi:mem-aref types :long 1) 0)
+ (let* ((model (gtk_list_store_newv 1 types))
+ (tv (gtk_tree_view_new_with_model model))
+ (name-key (climi::list-pane-name-key sheet))
+ (column (gtk_tree_view_column_new))
+ (renderer (gtk_cell_renderer_text_new)))
+ (setf (list-pane-tree-view sheet) tv)
+ (gtk_tree_view_column_pack_start column renderer 1)
+ (gtk_tree_view_insert_column tv column -1)
+ (gtk_tree_view_column_add_attribute column renderer "text" 0)
+ (gtk_tree_view_column_set_title column (list-pane-title sheet))
+ (cffi:with-foreign-object (&iter 'gtktreeiter)
+ (dolist (i (climi::list-pane-items sheet))
+ (gtk_list_store_append model &iter)
+ (cffi:with-foreign-string (n (funcall name-key i))
+ (cffi:with-foreign-object (&value 'gvalue)
+ (setf (cffi:foreign-slot-value &value 'gvalue 'type) 0)
+ (g_value_init &value +g-type-string+)
+ (g_value_set_string &value n)
+ (gtk_list_store_set_value model &iter 0 &value)))))
+ (gtk_tree_selection_set_mode
+ (list-pane-selection sheet)
+ (if (eq (climi::list-pane-mode sheet) :exclusive)
+ :browse
+ :multiple))
+ (gtk-list-reset-selection sheet)
+ (let ((ancestor
+ (and (sheet-parent sheet) (sheet-parent (sheet-parent sheet))))
+ (result tv))
+ (when (typep ancestor 'scroller-pane)
+ (uninstall-scroller-pane ancestor))
+ (let ((wrapper (gtk_scrolled_window_new
+ (gtk_tree_view_get_hadjustment tv)
+ (gtk_tree_view_get_vadjustment tv))))
+ (gtk_container_add wrapper tv)
+ (setf result wrapper))
+ (setf (list-pane-tree-view sheet) tv) ;?!
+ (gtk_tree_selection_set_select_function
+ (list-pane-selection sheet)
+ (cffi:get-callback 'view-selection-callback)
+ result
+ (cffi:null-pointer))
+ result))))
+
+(defun gtk-list-select-value (sheet value)
+ (let ((path
+ (gtk_tree_path_new_from_indices
+ (position value
+ (climi::list-pane-items sheet)
+ :key (climi::list-pane-value-key sheet)
+ :test (climi::list-pane-test sheet))
+ :int -1)))
+ (gtk_tree_selection_select_path (list-pane-selection sheet) path)
+ (gtk_tree_path_free path)))
+
+(defun gtk-list-reset-selection (sheet)
+ (gtk_tree_selection_unselect_all (list-pane-selection sheet))
+ (let ((value (gadget-value sheet)))
+ (if (eq (climi::list-pane-mode sheet) :exclusive)
+ (gtk-list-select-value sheet value)
+ (dolist (v value)
+ (gtk-list-select-value sheet v)))))
+
+(defmethod (setf gadget-value) :after
+ (value (gadget gtk-list) &key invoke-callback)
+ (declare (ignore invoke-callback))
+ (with-gtk ()
+ (let ((mirror (sheet-direct-mirror gadget)))
+ (when mirror
+ (gtk-list-reset-selection gadget)))))
+
(defun make-scale (fn sheet)
(let* ((min (df (gadget-min-value sheet)))
(max (df (gadget-max-value sheet)))
@@ -232,6 +336,10 @@
;; no signals
)
+(defmethod connect-native-signals ((sheet gtk-list) widget)
+ ;; no signals
+ )
+
;;;; Event handling
@@ -285,6 +393,40 @@
((pane gtk-nonmenu) (event magic-gadget-event))
(funcall (gtk-nonmenu-callback pane) pane nil))
+(defvar *list-selection-result*)
+
+(cffi:defcallback list-selection-callback :void
+ ((model :pointer)
+ (path :pointer)
+ (iter :pointer)
+ (data :pointer))
+ model iter data
+ (setf (gethash (cffi:mem-ref (gtk_tree_path_get_indices path) :int 0)
+ *list-selection-result*)
+ t))
+
+(defmethod handle-event
+ ((pane gtk-list) (event list-selection-event))
+ (with-gtk ()
+ (let ((*list-selection-result* (make-hash-table))
+ (value-key (climi::list-pane-value-key pane)))
+ (gtk_tree_selection_selected_foreach
+ (list-pane-selection pane)
+ (cffi:get-callback 'list-selection-callback)
+ (cffi:null-pointer))
+ (setf (gadget-value pane :invoke-callback t)
+ (if (eq (climi::list-pane-mode pane) :exclusive)
+ (loop
+ for i being each hash-key in *list-selection-result*
+ do (return
+ (funcall value-key
+ (elt (climi::list-pane-items pane) i))))
+ (loop
+ for i from 0
+ for value in (climi::list-pane-items pane)
+ when (gethash i *list-selection-result*)
+ collect (funcall value-key value)))))))
+
;;; COMPOSE-SPACE
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/12 13:46:08 1.13
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/12 20:12:19 1.14
@@ -290,6 +290,17 @@
(max_aspect :double)
(win_gravity :int))
+(cffi:defcstruct gtktreeiter
+ (stamp :int)
+ (user_data :pointer)
+ (user_data2 :pointer)
+ (user_data3 :pointer))
+
+(cffi:defcstruct gvalue
+ (type :ulong)
+ (data0 :uint64)
+ (data1 :uint64))
+
(cffi:defcenum gdkfunction
:copy :invert :xor :clear :and :and_reverse :and_invert :noop :or :equiv
:or_reverse :copy_invert :or_invert :nand :nor :set)
@@ -299,6 +310,9 @@
:step_up :step_down :page_up :page_down :step_left :step_right :page_left
:page_right :start :end)
+(cffi:defcenum gtkselectionmode
+ :none :single :browse :multiple)
+
;;; GTK functions
@@ -783,6 +797,131 @@
;; (data :pointer)
(data :long))
+(defcfun "gtk_tree_view_new_with_model"
+ :pointer
+ (model :pointer))
+
+(defcfun "gtk_list_store_newv"
+ :pointer
+ (columns :int)
+ (types :pointer))
+
+(defcfun "gtk_list_store_append"
+ :void
+ (list_store :pointer)
+ (iter :pointer))
+
+(defcfun "gtk_list_store_set_value"
+ :void
+ (list_store :pointer)
+ (iter :pointer)
+ (column :int)
+ (value :pointer))
+
+(defcfun "g_value_init"
+ :pointer
+ (gvalue :pointer)
+ (gtype :ulong))
+
+(defcfun "g_value_set_string"
+ :void
+ (gvalue :pointer)
+ (string :pointer))
+
+(defcfun "gtk_cell_renderer_text_new" :pointer)
+
+(defcfun "gtk_tree_view_column_new" :pointer)
+
+(defcfun "gtk_tree_view_column_get_widget"
+ :pointer
+ (column :pointer))
+
+(defcfun "gtk_tree_view_column_set_widget"
+ :void
+ (column :pointer)
+ (widget :pointer))
+
+(defcfun "gtk_tree_view_column_pack_start"
+ :void
+ (column :pointer)
+ (cell :pointer)
+ (expand :int))
+
+(defcfun "gtk_tree_view_insert_column"
+ :int
+ (treeview :pointer)
+ (column :pointer)
+ (position :int))
+
+(defcfun "gtk_tree_view_column_add_attribute"
+ :void
+ (column :pointer)
+ (renderer :pointer)
+ (attribute :string)
+ (column-index :int))
+
+(defcfun "gtk_tree_view_column_set_title"
+ :void
+ (column :pointer)
+ (title :string))
+
+(defcfun "gtk_scrolled_window_new"
+ :pointer
+ (hadjustment :pointer)
+ (vadjustment :pointer))
+
+(defcfun "gtk_tree_view_get_hadjustment"
+ :pointer
+ (tv :pointer))
+
+(defcfun "gtk_tree_view_get_vadjustment"
+ :pointer
+ (tv :pointer))
+
+(defcfun "gtk_tree_view_get_selection"
+ :pointer
+ (tv :pointer))
+
+(defcfun "gtk_tree_selection_set_mode"
+ :void
+ (selection :pointer)
+ (mode gtkselectionmode))
+
+(defcfun "gtk_tree_selection_unselect_all"
+ :void
+ (selection :pointer))
+
+(defcfun "gtk_tree_selection_select_path"
+ :void
+ (selection :pointer)
+ (path :pointer))
+
+(defcfun "gtk_tree_path_new_from_indices"
+ :pointer
+ (index :int)
+ &rest)
+
+(defcfun "gtk_tree_path_free"
+ :void
+ (path :pointer))
+
+(defcfun "gtk_tree_selection_set_select_function"
+ :void
+ (selection :pointer)
+ (fun :pointer)
+ (data :pointer)
+ (destroynotify :pointer))
+
+(defcfun "gtk_tree_path_get_indices"
+ :pointer
+ (path :pointer))
+
+(defcfun "gtk_tree_selection_selected_foreach"
+ :void
+ (selection :pointer)
+ (fun :pointer)
+ (data :pointer))
+
(defconstant GDK_EXPOSURE_MASK (ash 1 1))
(defconstant GDK_POINTER_MOTION_MASK (ash 1 2))
(defconstant GDK_POINTER_MOTION_HINT_MASK (ash 1 3))
More information about the Mcclim-cvs
mailing list