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