Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv15525
Modified Files: ffi.lisp frame-manager.lisp gadgets.lisp port.lisp Log Message:
Make demodemo ugly.
* gtk-ffi.lisp (gtk_frame_new): New. * gadgets.lisp (GTK-LABEL-PANE, REALIZE-NATIVE-WIDGET, CONTAINER-PUT, CONTAINER-MOVE, CONNECT-NATIVE-SIGNALS): New class. (*USE-FRONTENT-COMPOSE-SPACE*, (COMPOSE-SPACE NATIVE-WIDGET-MIXIN)): New hack to by-pass GTK+ layouting. (COMPOSE-SPACE GTK-LABEL-PANE): Let the frontend decide. * port.lisp (CONTAINER-PUT, CONTAINER-MOVE): New generic function and default methods. (REALIZE-MIRROR, PORT-SET-MIRROR-TRANSFORMATION): Use CONTAINER-*.
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/11/19 17:21:47 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/11/19 17:31:20 1.3 @@ -966,6 +966,11 @@ (has_window :int) ;gboolean )
+(defcfun "gtk_frame_new" + :pointer + (label :string) ;const gchar * + ) + (defcfun "gtk_get_current_event_time" :uint32)
(defcfun "gtk_hscale_new_with_range" --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/11/12 20:37:14 1.7 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/11/19 17:31:20 1.8 @@ -96,6 +96,9 @@ (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:label-pane)) &rest initargs) + (apply #'make-instance 'gtk-label-pane initargs)) + (defmethod adopt-frame :after ((fm gtkairo-frame-manager) (frame application-frame)) ()) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/19 15:55:10 1.10 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/19 17:31:20 1.11 @@ -69,6 +69,8 @@ (defclass gtk-vscrollbar (native-scrollbar) ()) (defclass gtk-hscrollbar (native-scrollbar) ())
+(defclass gtk-label-pane (native-widget-mixin label-pane) + ((label-pane-fixed :accessor label-pane-fixed)))
;;;; Constructors
@@ -86,6 +88,21 @@ (gtk_toggle_button_set_active widget (if (gadget-value sheet) 1 0)) widget))
+(defmethod realize-native-widget ((sheet gtk-label-pane)) + (let ((frame (gtk_frame_new (climi::label-pane-label sheet))) + (fixed (gtk_fixed_new))) + (setf (label-pane-fixed sheet) fixed) + (gtk_container_add frame fixed) + frame)) + +(defmethod container-put ((parent gtk-label-pane) parent-widget child x y) + (declare (ignore parent-widget)) + (gtk_fixed_put (label-pane-fixed parent) child x y)) + +(defmethod container-move ((parent gtk-label-pane) parent-widget child x y) + (declare (ignore parent-widget)) + (gtk_fixed_move (label-pane-fixed parent) child x y)) + (defconstant +g-type-string+ (ash 16 2))
(defun uninstall-scroller-pane (pane) @@ -343,6 +360,10 @@ ;; no signals )
+(defmethod connect-native-signals ((sheet gtk-label-pane) widget) + ;; no signals + ) +
;;;; Event handling
@@ -433,20 +454,25 @@
;;; COMPOSE-SPACE
+(defvar *use-frontend-compose-space* nil) + ;; KLUDGE: this is getting called before the sheet has been realized. (defmethod compose-space ((gadget native-widget-mixin) &key width height) (declare (ignore width height)) - (let* ((widget (native-widget gadget)) - (widgetp widget)) - (unless widgetp - (setf widget (realize-native-widget gadget))) - (prog1 - (cffi:with-foreign-object (r 'gtkrequisition) - (gtk_widget_size_request widget r) - (cffi:with-foreign-slots ((width height) r gtkrequisition) - (make-space-requirement :width width :height height))) - (unless widgetp - (gtk_widget_destroy widget))))) + (if *use-frontend-compose-space* + (let ((*use-frontend-compose-space* nil)) + (call-next-method)) + (let* ((widget (native-widget gadget)) + (widgetp widget)) + (unless widgetp + (setf widget (realize-native-widget gadget))) + (prog1 + (cffi:with-foreign-object (r 'gtkrequisition) + (gtk_widget_size_request widget r) + (cffi:with-foreign-slots ((width height) r gtkrequisition) + (make-space-requirement :width width :height height))) + (unless widgetp + (gtk_widget_destroy widget))))))
(defmethod compose-space ((gadget gtk-menu-bar) &key width height) (declare (ignore width height)) @@ -468,6 +494,11 @@ (unless widgetp (gtk_widget_destroy widget)))))
+(defmethod compose-space ((gadget gtk-label-pane) &key width height) + (declare (ignore width height)) + (let ((*use-frontend-compose-space* t)) + (call-next-method))) +
;;; Vermischtes
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/19 15:55:11 1.10 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/19 17:31:20 1.11 @@ -250,6 +250,12 @@ (t +white+)))
+(defmethod container-put ((parent sheet) parent-widget child x y) + (gtk_fixed_put parent-widget child x y)) + +(defmethod container-move ((parent sheet) parent-widget child x y) + (gtk_fixed_move parent-widget child x y)) + (defmethod realize-mirror ((port gtkairo-port) (sheet mirrored-sheet-mixin)) (with-gtk () (let* ((parent (sheet-mirror (sheet-parent sheet))) @@ -271,7 +277,7 @@ (transform-position (climi::%sheet-mirror-transformation sheet) 0 0) (setf x (round-coordinate x)) (setf y (round-coordinate y)) - (gtk_fixed_put (mirror-widget parent) widget x y)) + (container-put (sheet-parent sheet) (mirror-widget parent) widget x y)) (climi::port-register-mirror (port sheet) sheet mirror) (gtk-widget-modify-bg widget (sheet-desired-color sheet)) (when (sheet-enabled-p sheet) @@ -321,7 +327,7 @@ (transform-position (climi::%sheet-mirror-transformation sheet) 0 0) (setf x (round-coordinate x)) (setf y (round-coordinate y)) - (gtk_fixed_put (mirror-widget parent) fixed x y)) + (container-put (sheet-parent sheet) (mirror-widget parent) fixed x y)) (gtk_fixed_put fixed widget 0 0) (climi::port-register-mirror (port sheet) sheet mirror) (when (sheet-enabled-p sheet) @@ -523,19 +529,21 @@ ((port gtkairo-port) (mirror mirror) mirror-transformation) (with-gtk () (let* ((w (mirror-widget mirror)) + (parent-sheet (sheet-parent (climi::port-lookup-sheet port mirror))) (parent (cffi:foreign-slot-value w 'gtkwidget 'parent))) (multiple-value-bind (x y) (transform-position mirror-transformation 0 0) - (gtk_fixed_move parent w (floor x) (floor y)))))) + (container-move parent-sheet parent w (floor x) (floor y))))))
(defmethod port-set-mirror-transformation ((port gtkairo-port) (mirror native-widget-mirror) mirror-transformation) (with-gtk () (let* ((w (mirror-fixed mirror)) + (parent-sheet (sheet-parent (climi::port-lookup-sheet port mirror))) (parent (cffi:foreign-slot-value w 'gtkwidget 'parent))) (multiple-value-bind (x y) (transform-position mirror-transformation 0 0) - (gtk_fixed_move parent w (floor x) (floor y)))))) + (container-move parent-sheet parent w (floor x) (floor y))))))
;;;; An und aus