[mcclim-cvs] CVS mcclim/Backends/gtkairo
dlichteblau
dlichteblau at common-lisp.net
Sun Feb 4 12:55:44 UTC 2007
Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo
In directory clnet:/tmp/cvs-serv1773/Backends/gtkairo
Modified Files:
event.lisp ffi.lisp frame-manager.lisp gadgets.lisp port.lisp
Log Message:
Added the tab layout.
* Extensions/tab-layout.lisp: New file.
* Examples/tabdemo.lisp: New file.
* mcclim.asd (CLIM): Added Extensions/tab-layout.lisp.
(CLIM-EXAMPLES): Add tabdemo.lisp
* package.lisp (CLIM-TAB-LAYOUT): New package.
* Examples/demodemo.lisp: Added a button for the tabdemo.
* Doc/make-docstrings.lisp: Process the clim-tab-layout package.
* Doc/mcclim.texi: New chapter about the tab-layout.
* Backends/CLX/frame-manager.lisp (GENERATE-STANDARD-PANE-SPECS,
FIND-CONCRETE-PANE-CLASS): Obey define-abstract-pane-mapping even
for names not the internal packages.
* Backends/gtkairo/event.lisp (TAB-BUTTON-HANDLER): New.
* Backends/gtkairo/frame-manager.lisp ((MAKE-PANE-2
TAB-LAYOUT-PANE)): New. (RESOLVE-ABSTRACT-PANE-NAME): Renamed.
* Backends/gtkairo/gadgets.lisp (TAB-BUTTON-EVENT,
TAB-PRESS-EVENT, TAB-RELEASE-EVENT, GTK-TAB-LAYOUT): New classes.
(REALIZE-NATIVE-WIDGET, CONTAINER-PUT, (SETF
CLIM-TAB-LAYOUT:TAB-LAYOUT-PAGES), REORDER-NOTEBOOK-PAGES,
CONTAINER-MOVE, ALLOCATE-SPACE, (SETF
CLIM-TAB-LAYOUT:TAB-LAYOUT-ENABLED-PAGE), CONNECT-NATIVE-SIGNALS,
CLIM-TAB-LAYOUT:NOTE-TAB-PAGE-CHANGED, SET-TAB-PAGE-ATTRIBUTES,
HANDLE-EVENT): New functions and methods on gtk-tab-layout.
(PARENT-AD-HOC-PRESENTATION): New class.
* Backends/gtkairo/port.lisp (GTK-WIDGET-MODIFY-FG): New function.
* Backends/gtkairo/ffi.lisp: Regenerated.
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/12/27 14:47:24 1.18
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2007/02/04 12:55:43 1.19
@@ -307,6 +307,28 @@
(t
0)))))
+(define-signal (tab-button-handler :return-type :int) (widget event)
+ (cffi:with-foreign-slots
+ ((type time button state x y x_root y_root) event gdkeventbutton)
+ (when (eql type GDK_BUTTON_PRESS)
+ ;; Hack alert: Menus don't work without this.
+ (gdk_pointer_ungrab GDK_CURRENT_TIME))
+ (setf *last-seen-button* button)
+ (let ((page (widget->sheet widget *port*)))
+ (enqueue (make-instance
+ (if (eql type GDK_BUTTON_PRESS)
+ 'tab-press-event
+ 'tab-release-event)
+ :button (ecase button
+ (1 +pointer-left-button+)
+ (2 +pointer-middle-button+)
+ (3 +pointer-right-button+)
+ (4 +pointer-wheel-up+)
+ (5 +pointer-wheel-down+))
+ :page page
+ :sheet (clim-tab-layout:tab-page-tab-layout page)))))
+ 1)
+
(define-signal enter-handler (widget event)
(cffi:with-foreign-slots
((time state x y x_root y_root) event gdkeventcrossing)
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/26 16:44:46 1.15
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2007/02/04 12:55:44 1.16
@@ -677,11 +677,6 @@
(arg0 :pointer) ;cairo_t *
)
-(defcfun "cairo_stroke_preserve"
- :void
- (arg0 :pointer) ;cairo_t *
- )
-
(defcfun "cairo_stroke_extents"
:void
(arg0 :pointer) ;cairo_t *
@@ -691,6 +686,11 @@
(arg4 :pointer) ;double *
)
+(defcfun "cairo_stroke_preserve"
+ :pointer
+ (arg0 :pointer) ;cairo_t *
+ )
+
(defcfun "cairo_surface_create_similar"
:pointer
(arg0 :pointer) ;cairo_surface_t *
@@ -1115,6 +1115,11 @@
(value :double) ;gdouble
)
+(defcfun "gtk_bin_get_child"
+ :pointer
+ (bin :pointer) ;GtkBin *
+ )
+
(defcfun "gtk_button_new_with_label"
:pointer
(label :string) ;const gchar *
@@ -1152,6 +1157,20 @@
(widget :pointer) ;GtkWidget *
)
+(defcfun "gtk_event_box_new" :pointer)
+
+(defcfun "gtk_event_box_set_above_child"
+ :void
+ (event_box :pointer) ;GtkEventBox *
+ (above_child :int) ;gboolean
+ )
+
+(defcfun "gtk_event_box_set_visible_window"
+ :void
+ (event_box :pointer) ;GtkEventBox *
+ (visible_window :int) ;gboolean
+ )
+
(defcfun "gtk_events_pending" :int)
(defcfun "gtk_fixed_move"
@@ -1203,6 +1222,17 @@
(argv :pointer) ;char ***
)
+(defcfun "gtk_label_new"
+ :pointer
+ (str :string) ;const gchar *
+ )
+
+(defcfun "gtk_label_set_text"
+ :void
+ (label :pointer) ;GtkLabel *
+ (str :string) ;const gchar *
+ )
+
(defcfun "gtk_list_store_append"
:void
(list_store :pointer) ;GtkListStore *
@@ -1265,6 +1295,53 @@
(child :pointer) ;GtkWidget *
)
+(defcfun "gtk_notebook_append_page"
+ :int
+ (notebook :pointer) ;GtkNotebook *
+ (child :pointer) ;GtkWidget *
+ (tab_label :pointer) ;GtkWidget *
+ )
+
+(defcfun "gtk_notebook_get_current_page"
+ :int
+ (notebook :pointer) ;GtkNotebook *
+ )
+
+(defcfun "gtk_notebook_get_tab_label"
+ :pointer
+ (notebook :pointer) ;GtkNotebook *
+ (child :pointer) ;GtkWidget *
+ )
+
+(defcfun "gtk_notebook_insert_page"
+ :int
+ (notebook :pointer) ;GtkNotebook *
+ (child :pointer) ;GtkWidget *
+ (tab_label :pointer) ;GtkWidget *
+ (position :int) ;gint
+ )
+
+(defcfun "gtk_notebook_new" :pointer)
+
+(defcfun "gtk_notebook_remove_page"
+ :void
+ (notebook :pointer) ;GtkNotebook *
+ (page_num :int) ;gint
+ )
+
+(defcfun "gtk_notebook_reorder_child"
+ :void
+ (notebook :pointer) ;GtkNotebook *
+ (child :pointer) ;GtkWidget *
+ (position :int) ;gint
+ )
+
+(defcfun "gtk_notebook_set_current_page"
+ :void
+ (notebook :pointer) ;GtkNotebook *
+ (page_num :int) ;gint
+ )
+
(defcfun "gtk_radio_button_get_group"
:pointer
(radio_button :pointer) ;GtkRadioButton *
@@ -1454,6 +1531,11 @@
(widget :pointer) ;GtkWidget *
)
+(defcfun "gtk_widget_get_parent"
+ :pointer
+ (widget :pointer) ;GtkWidget *
+ )
+
(defcfun "gtk_widget_get_pointer"
:void
(widget :pointer) ;GtkWidget *
@@ -1490,6 +1572,18 @@
(color :pointer) ;const GdkColor *
)
+(defcfun "gtk_widget_modify_fg"
+ :void
+ (widget :pointer) ;GtkWidget *
+ (state GtkStateType)
+ (color :pointer) ;const GdkColor *
+ )
+
+(defcfun "gtk_widget_queue_draw"
+ :void
+ (widget :pointer) ;GtkWidget *
+ )
+
(defcfun "gtk_widget_set_double_buffered"
:void
(widget :pointer) ;GtkWidget *
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/12/10 19:33:05 1.10
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2007/02/04 12:55:44 1.11
@@ -24,7 +24,9 @@
(defclass gtkairo-frame-manager (frame-manager)
())
-(defun frob-stupid-type-spec (type)
+;; fixme! we're supposed to dispatch on the abstract name, not resolve
+;; it to the (incorrect) concrete generic class name and dispatch on that.
+(defun resolve-abstract-pane-name (type)
(when (get type 'climi::concrete-pane-class-name)
(setf type (get type 'climi::concrete-pane-class-name)))
(class-name
@@ -38,7 +40,7 @@
(defmethod make-pane-1
((fm gtkairo-frame-manager) (frame application-frame) type &rest initargs)
(apply #'make-pane-2
- (frob-stupid-type-spec type)
+ (resolve-abstract-pane-name type)
:frame frame
:manager fm
:port (port frame)
@@ -99,6 +101,10 @@
(defmethod make-pane-2 ((type (eql 'clim:generic-list-pane)) &rest initargs)
(apply #'make-instance 'gtk-list initargs))
+(defmethod make-pane-2
+ ((type (eql 'clim-tab-layout:tab-layout-pane)) &rest initargs)
+ (apply #'make-instance 'gtk-tab-layout initargs))
+
(defmethod make-pane-2 ((type (eql 'clim:label-pane)) &rest initargs)
(apply #'make-instance 'gtk-label-pane initargs))
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/12/27 14:47:24 1.20
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2007/02/04 12:55:44 1.21
@@ -37,6 +37,13 @@
(defclass list-selection-event (gadget-event) ())
+(defclass tab-button-event (gadget-event)
+ ((page :initarg :page :accessor event-page)
+ (button :initarg :button :accessor event-button)))
+
+(defclass tab-press-event (tab-button-event) ())
+(defclass tab-release-event (tab-button-event) ())
+
;;;; Classes
@@ -80,6 +87,11 @@
(label-pane-extra-width :accessor label-pane-extra-width)
(label-pane-extra-height :accessor label-pane-extra-height)))
+(defclass gtk-tab-layout (native-widget-mixin clim-tab-layout:tab-layout)
+ ((tab-layout-extra-width :accessor tab-layout-extra-width)
+ (tab-layout-extra-height :accessor tab-layout-extra-height)))
+
+
;;;; Constructors
(defmethod realize-native-widget ((sheet gtk-button))
@@ -277,6 +289,97 @@
((pane gtk-list) (event pointer-button-release-event))
nil)
+(defmethod realize-native-widget ((sheet gtk-tab-layout))
+ (let ((result (gtk_notebook_new))
+ (dummy-child (gtk_fixed_new))
+ (dummy-label (gtk_label_new "foo")))
+ (gtk_notebook_append_page result dummy-child dummy-label)
+ (gtk_widget_show dummy-child)
+ (let* ((q
+ (reduce (lambda (x y)
+ (space-requirement-combine #'max x y))
+ (mapcar #'compose-space (sheet-children sheet))
+ :initial-value
+ (make-space-requirement
+ :width 0 :min-width 0 :max-width 0
+ :height 0 :min-height 0 :max-height 0)))
+ (width1 (space-requirement-width q))
+ (height1 (space-requirement-height q)))
+ (gtk_widget_set_size_request dummy-child width1 height1)
+ (cffi:with-foreign-object (r 'gtkrequisition)
+ (gtk_widget_size_request result r)
+ (cffi:with-foreign-slots ((width height) r gtkrequisition)
+ (setf (tab-layout-extra-width sheet) (- width width1))
+ (setf (tab-layout-extra-height sheet) (- height height1))))
+ (gtk_notebook_remove_page result 0))
+ result))
+
+(defmethod container-put ((parent gtk-tab-layout) parent-widget child x y)
+ (declare (ignore x y))
+ (let* ((page (clim-tab-layout:sheet-to-page
+ (widget->sheet child (port parent))))
+ (index (position page (clim-tab-layout:tab-layout-pages parent)))
+ (label (gtk_label_new (clim-tab-layout:tab-page-title page)))
+ (box (gtk_event_box_new)))
+ (gtk_event_box_set_visible_window box 0)
+ (gtk_container_add box label)
+ (gtk_widget_show_all box)
+ ;; naja, ein sheet ist das nicht
+ (setf (widget->sheet box (port parent)) page)
+ (connect-signal box "button-press-event" 'tab-button-handler)
+ (gtk_widget_show child)
+ (gtk_notebook_insert_page parent-widget child box index)
+ (set-tab-page-attributes page label)
+ ;; fixme:
+ (reorder-notebook-pages parent)
+ (setf (clim-tab-layout:tab-layout-enabled-page parent)
+ (clim-tab-layout:tab-layout-enabled-page parent))))
+
+(defmethod (setf clim-tab-layout:tab-layout-pages)
+ :after
+ (newval (parent gtk-tab-layout))
+ (declare (ignore newval))
+ (reorder-notebook-pages parent))
+
+(defun reorder-notebook-pages (parent)
+ (loop
+ for page in (clim-tab-layout:tab-layout-pages parent)
+ for i from 0
+ do
+ (let* ((pane (clim-tab-layout:tab-page-pane page))
+ (mirror (climi::port-lookup-mirror (port parent) pane)))
+ (when mirror
+ (gtk_notebook_reorder_child
+ (native-widget parent)
+ (mirror-widget mirror)
+ i)))))
+
+(defmethod container-move ((parent gtk-tab-layout) parent-widget child x y)
+ (declare (ignore parent-widget child x y)))
+
+(defmethod allocate-space ((pane gtk-tab-layout) width height)
+ (dolist (page (clim-tab-layout:tab-layout-pages pane))
+ (let ((child (clim-tab-layout:tab-page-pane page)))
+ (move-sheet child 0 0) ;dummy
+ (allocate-space child
+ (- width (tab-layout-extra-width pane))
+ (- height (tab-layout-extra-height pane))))))
+
+(defmethod allocate-space :around ((pane gtk-tab-layout) width height)
+ ;; ARGH! Force the around method in panes.lisp to c-n-m.
+ (setf (climi::pane-current-width pane) nil)
+ (call-next-method))
+
+(defmethod (setf clim-tab-layout:tab-layout-enabled-page)
+ :after
+ (newval (parent gtk-tab-layout))
+ (when (and (native-widget parent) newval)
+ ;; fixme:
+ (reorder-notebook-pages parent)
+ (gtk_notebook_set_current_page
+ (native-widget parent)
+ (position newval (clim-tab-layout:tab-layout-pages parent)))))
+
(defun option-pane-set-active (sheet widget)
(gtk_combo_box_set_active
widget
@@ -458,6 +561,10 @@
;; no signals
)
+(defmethod connect-native-signals ((sheet gtk-tab-layout) widget)
+ ;; no signals
+ )
+
(defmethod connect-native-signals ((sheet gtk-option-pane) widget)
(connect-signal widget "changed" 'magic-clicked-handler))
@@ -510,6 +617,66 @@
(:command
(climi::throw-object-ptype item 'menu-item)))))
+;;;(defmethod handle-event
+;;; ((pane gtk-tab-layout) (event tab-release-event))
+;;; )
+
+(defclass parent-ad-hoc-presentation (climi::ad-hoc-presentation)
+ ((ad-hoc-children :initarg :ad-hoc-children
+ :reader output-record-children)))
+
+(defmethod clim-tab-layout:note-tab-page-changed ((layout gtk-tab-layout) page)
+ (with-gtk ()
+ (let* ((pane (clim-tab-layout:tab-page-pane page))
+ (mirror (climi::port-lookup-mirror (port layout) pane)))
+ (when mirror
+ (let ((box (gtk_notebook_get_tab_label (native-widget layout)
+ (mirror-widget mirror))))
+ (set-tab-page-attributes page (gtk_bin_get_child box)))))))
+
+(defun set-tab-page-attributes (page label)
+ ;; fixme: wieso funktioniert das in der tabdemo, nicht aber in beirc?
+ (let ((ink (getf (clim-tab-layout:tab-page-drawing-options page) :ink)))
+ (when ink
+ (gtk-widget-modify-fg label ink)))
+ (gtk_label_set_text label (clim-tab-layout:tab-page-title page))
+ (gtk_widget_queue_draw label))
+
+(defmethod handle-event
+ ((pane gtk-tab-layout) (event tab-press-event))
+ (let* ((page (event-page event))
+ (ptype (clim-tab-layout:tab-page-presentation-type page))
+ (inner-presentation
+ (make-instance 'climi::ad-hoc-presentation
+ :object page
+ :single-box t
+ :type 'clim-tab-layout:tab-page))
+ (presentation
+ (make-instance 'parent-ad-hoc-presentation
+ :ad-hoc-children (vector inner-presentation)
+ :object page
+ :single-box t
+ :type ptype)))
+ (case (event-button event)
+ (#.+pointer-right-button+
+ (call-presentation-menu
+ presentation
+ *input-context*
+ *application-frame*
+ pane
+ 42 42
+ :for-menu t
+ :label (format nil "Operation on ~A" ptype)))
+ (#.+pointer-left-button+
+ (throw-highlighted-presentation
+ presentation
+ *input-context*
+ (make-instance 'pointer-button-press-event
+ :sheet pane
+ :x 42 :y 42
+ :modifier-state 0
+ :button (event-button event)))))))
+
(defmethod handle-event
((pane gtk-nonmenu) (event magic-gadget-event))
(funcall (gtk-nonmenu-callback pane) pane nil))
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/12/25 21:34:57 1.15
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2007/02/04 12:55:44 1.16
@@ -244,6 +244,10 @@
(with-gdkcolor (c color)
(gtk_widget_modify_bg widget 0 c)))
+(defun gtk-widget-modify-fg (widget color)
+ (with-gdkcolor (c color)
+ (gtk_widget_modify_fg widget 0 c)))
+
;; copy&paste from port.lisp|CLX:
(defun sheet-desired-color (sheet)
(typecase sheet
More information about the Mcclim-cvs
mailing list