[mcclim-cvs] CVS mcclim/Backends/gtkairo
dlichteblau
dlichteblau at common-lisp.net
Sun Nov 19 17:31:20 UTC 2006
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
More information about the Mcclim-cvs
mailing list