Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv5822
Modified Files: BUGS cairo-ffi.lisp event.lisp frame-manager.lisp gadgets.lisp gtk-ffi.lisp medium.lisp port.lisp Log Message: Some flipping ink de-pessimisation. Good speedup in the drawing benchmark. Helps only with local X for me. Breaks totally on Windows, so not enabled there yet.
* medium.lisp (FLIPPING-PIXMAP): Default to NIL. (SYNC-SHEET): Free flipping-pixmap. Use pushnew, not push. (DISPOSE-FLIPPING-PIXMAP): New function. (APPLY-FLIPPING-INK): Don't free flipping-pixmap (except on Windows, for now). Bugfix: Use sheet-mirror-region instead of GtkWidget.allocation. ((SYNC-INK flipping-ink)): Use the cached flipping pixmap if present. Bugfix like above. (DESTROY-CAIRO-MEDIUM): Free flipping-pixmap.
* port.lisp (DESTROY-MEDIUMS): Free flipping-pixmap.
Repair windows port:
* medium.lisp (MEDIUM-DRAW-TEXT*): Don't pass empty strings to cairo. (CAIRO-TEXT-EXTENTS): Ditto (new function). (TEXT-SIZE, CLIMI::TEXT-BOUNDING-RECTANGLE*): Call cairo-text-extents.
Native menus:
* event.lisp (MENU-CLICKED-HANDLER): New function.
* frame-manager.lisp (MAKE-PANE-2): New methods for MENU-BUTTON-LEAF-PANE, MENU-BUTTON-SUBMENU-PANE, and MENU-BAR.
* port.lisp (GTK-MENU, GTK-NONMENU, GTK-MENU-BAR, MENU-MIRROR, NONMENU-MIRROR): New classes. ((REALIZE-MIRROR GTK-MENU), (REALIZE-MIRROR GTK-NONMENU), (DESTROY-MIRROR GTK-MENU), (DESTROY-MIRROR GTK-NONMENU)): New methods.
* gtk-ffi.lisp (GTK_MENU_ITEM_NEW_WITH_LABEL, GTK_MENU_BAR_NEW, GTK_MENU_SHELL_APPEND, GTK_MENU_ITEM_SET_SUBMENU, GTK_MENU_NEW, GTK_SEPARATOR_MENU_ITEM_NEW): New foreign function declarations. * gadgets.lisp (MENU-CLICKED-EVENT): New class. ((REALIZE-NATIVE-WIDGET GTK-MENU-BAR), (CONNECT-NATIVE-SIGNALS GTK-MENU-BAR) (HANDLE-EVENT GTK-MENU MENU-CLICKED-EVENT) (HANDLE-EVENT GTK-NONMENU MAGIC-GADGET-EVENT), (COMPOSE-SPACE GTK-MENU-BAR)): New methods. (APPEND-MENU-ITEMS, MAKE-NATIVE-MENU-ITEM): New functions.
Unsuccessful attempt at native context menus, checked in anyway in the hope that it's not broken beyond repair. Bugs: Doesn't get notified when the context menu is closed without an item having been selected (perhaps solvable through low-level hackery). Sometimes doesn't appear at all (fixme). Assertion fails on #+clim-mp (gna).
* event.lisp (CONTEXT-MENU-CLICKED-HANDLER): New function.
* frame-manager.lisp (FRAME-MANAGER-MENU-CHOOSE): New method, commented out for now.
* gadgets.lisp (CONTEXT-MENU-CLICKED-EVENT, DUMMY-CONTEXT-MENU-SHEET, DUMMY-MENU-ITEM-SHEET): New classes. (DESTRUCTURE-MC-MENU-ITEM, MAKE-CONTEXT-MENU): New functions.
* gtk-ffi.lisp (GTK_MENU_POPUP, GTK_GET_CURRENT_EVENT_TIME): New foreign function declarations.
Fix climacs startup by always blocking in the native event loop. I cannot figure out what GTK+ does that sb-sys:wait-until-fd-usable didn't, so I am not entirely confident that this change is really the right thing. DESTROY-PORT seems broken now as a consequence of interrupting the native code. Anyway, in the name of short-term bug fixing:
* event.lisp (GET-NEXT-EVENT): Disable the hack that was used to avoid blocking in foreign code.
Misc:
* cairo-ffi.lisp (*CAIRO-ERROR-MODE*): Removed. (DEF-CAIRO-FUN): Signal an ERROR, unconditionally. (cairo_get_font_face, cairo_font_face_status): New foreign function declarations.
* medium.lisp (ASSERT-FONT-STATUS): New function. (SYNC-TEXT-STYLE): Check font error status.
* event.lisp (KEY-HANDLER): Minor rearrangement.
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/05/07 14:33:04 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/05/13 19:37:29 1.10 @@ -27,20 +27,28 @@ (FIXED) 5d. Default gadget values aren't being used.
-6. - Should work on Windows but does not. Using the installer from - gimp-win.sf.net I see an address book window, but there are cairo - font warnings in the background and font metrik functions return - totally bogus values sometimes. - Although the hordes of sbcl/win32 hackers might contribute a native - Windows backend sooner or later, it would be nice to get Gtkairo - working on Windows, too. - -7. - (some?) drawing operations are rather slow. (Remote X to an ancient - server spends insane amounts of real (!) time doing XGetImage - requests. But even locally, where that isn't reproducable, it's not - really snappy. Just try scrolling in beirc.) +(FIXED) 6. + [Address book didn't work on windows.] + +6b. + On windows, something draws gray ink over the buttons in demodemo + after expose events. This should not happen, since the gtkbuttons + are in a gtkfixed with its own window. Thorough double buffering + of all output seems to be a viable workaround though. + +6c. + On windows, all we get is a sans serif font. No serif and notably + no monospace font, breaking climacs like bug 3 did. + +7a. + flipping ink takes time proportional to the with the size of the + window, not with the size of the shape being drawn + +7b. + flipping ink pixmap caching is broken on windows + +7c. + text drawing is noticably slower than with CLX
8. The frontend specifies background colors (*3d-normal-color*) where @@ -66,14 +74,14 @@ In the address book, there are often wide grey borders instead of the narrow black ones.
-13. +(WONTFIX) 13. McCLIM seems to think that things like button panes have a maximum size equal to their preferred size. I don't agree and return the default gtk size as space-requirement :width and :height without giving a maximum or minimum size at all. Naturally, the existing demos look a little, erm, different with that.
-14. +(FIXED?) 14. Climacs doesn't draw itself until the window is resized.
(FIXED) 15. @@ -101,5 +109,11 @@ modifier bit set; key release events do. This is opposite to what CLIM-CLX does.
-20. +(NOTABUG) 20. Very nasty duplicate keyboard events when typing in the listener. + +21. + Copy&paste needs to be implemented. + +22. + medium-draw-ellipse* needs a rewrite. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp 2006/04/23 17:36:28 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp 2006/05/13 19:37:29 1.4 @@ -25,9 +25,6 @@ (in-package :clim-gtkairo)
-(defvar *cairo-error-mode* :warn - "NIL, :WARN, or :BREAK.") - (defmacro def-cairo-fun (name rtype &rest args) (let* ((str (string-upcase name)) (actual (intern (concatenate 'string "%-" str) :clim-gtkairo)) @@ -40,12 +37,9 @@ (defun ,wrapper ,argnames (multiple-value-prog1 (,actual ,@argnames) - (when *cairo-error-mode* - (let ((status (cairo_status ,(car argnames)))) - (unless (eq status :success) - (warn "~A returned with status ~A" ,name status)) - (when (eq *cairo-error-mode* :break) - (break))))))))) + (let ((status (cairo_status ,(car argnames)))) + (unless (eq status :success) + (error "~A returned with status ~A" ,name status))))))))
;; user-visible structures @@ -608,6 +602,14 @@ :void (cr :pointer))
+(def-cairo-fun "cairo_get_font_face" + :pointer + (cr :pointer)) + +(defcfun "cairo_font_face_status" + cairo_status + (font :pointer)) +
;;; Error status queries
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/05/07 14:29:06 1.7 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/05/13 19:37:29 1.8 @@ -101,9 +101,9 @@ (cond ((dequeue port)) (t - #+(and sbcl (not win32)) - (sb-sys:wait-until-fd-usable (gdk-xlib-fd) :input timeout) - (gtk-main-iteration port #-(and sbcl (not win32)) t) + #+clim-gtkairo::do-not-block-in-ffi + (sb-sys:wait-until-fd-usable (gdk-xlib-fd) :input 0.1) + (gtk-main-iteration port #-clim-gtkairo::do-not-block-in-ffi t) (dequeue port))))
(defmacro define-signal (name+options (widget event &rest args) &body body) @@ -193,18 +193,15 @@ ;; fixme: what about the other characters in `string'? (char string 0))) (sym (gethash keyval *keysyms*))) - ;; McCLIM will #\a statt ^A sehen: (cond + ((eq sym :backspace) + (setf char #\backspace)) ((null char)) ((eql char #\return)) ((eql char #\escape) (setf char nil)) ((< 0 (char-code char) 32) (setf char (code-char (+ (char-code char) 96))))) - (when (eq sym :backspace) - (setf char #\backspace)) - ;; irgendwas sagt mir, dass hier noch weitere Korrekturen - ;; werden folgen muessen. (enqueue (make-instance (if (eql type GDK_KEY_PRESS) 'key-press-event @@ -321,6 +318,23 @@ (make-instance 'magic-gadget-event :sheet (widget->sheet widget *port*)))))
+(define-signal menu-clicked-handler (widget event) + (declare (ignore event)) + (let ((parent (cffi:foreign-slot-value widget 'gtkwidget 'parent))) + (enqueue + (make-instance 'menu-clicked-event + :sheet (widget->sheet parent *port*) + :item (widget->sheet widget *port*))))) + +(define-signal context-menu-clicked-handler (widget event) + (declare (ignore event)) + (let ((dummy-item (widget->sheet widget *port*))) + (enqueue + (make-instance 'context-menu-clicked-event + :sheet (dummy-menu-item-sheet-parent dummy-item) + :value (dummy-menu-item-sheet-value dummy-item) + :itemspec (dummy-menu-item-sheet-itemspec dummy-item))))) + #-sbcl (define-signal (scrollbar-change-value-handler :return-type :int) (widget (scroll gtkscrolltype) (value :double)) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/05/01 21:21:39 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/05/13 19:37:29 1.4 @@ -50,6 +50,17 @@ (defmethod make-pane-2 ((type (eql 'push-button-pane)) &rest initargs) (apply #'make-instance 'gtk-button initargs))
+(defmethod make-pane-2 + ((type (eql 'climi::menu-button-leaf-pane)) &rest initargs) + (apply #'make-instance 'gtk-nonmenu initargs)) + +(defmethod make-pane-2 + ((type (eql 'climi::menu-button-submenu-pane)) &rest initargs) + (apply #'make-instance 'gtk-menu initargs)) + +(defmethod make-pane-2 ((type (eql 'climi::menu-bar)) &rest initargs) + (apply #'make-instance 'gtk-menu-bar initargs)) + ;;;(defmethod make-pane-2 ((type (eql 'clim:check-box-pane)) &rest initargs) ;;; (apply #'make-instance gtkairo-check-box-pane initargs)) ;;;(defmethod make-pane-2 ((type (eql 'clim:radio-box-pane)) &rest initargs) @@ -104,3 +115,37 @@ ((fm gtkairo-frame-manager) (frame climi::menu-frame)) (port-enable-sheet (car climi::*all-ports*) (slot-value frame 'climi::top-level-sheet))) + +#+(or) ;doesn't work yet +(defmethod frame-manager-menu-choose + ((frame-manager gtkairo-frame-manager) + items + &key associated-window printer presentation-type + (default-item nil default-item-p) + text-style label cache unique-id id-test cache-value cache-test + max-width max-height n-rows n-columns x-spacing y-spacing row-wise + cell-align-x cell-align-y scroll-bars pointer-documentation) + (declare + ;; XXX hallo? + (ignore printer presentation-type default-item default-item-p + text-style label cache unique-id id-test cache-value + cache-test max-width max-height n-rows n-columns x-spacing + y-spacing row-wise cell-align-x cell-align-y scroll-bars + pointer-documentation)) + (let* ((frame (if associated-window + (pane-frame associated-window) + *application-frame*)) + (port (port frame)) + (tls (slot-value frame 'climi::top-level-sheet)) + (tls-mirror (climi::port-lookup-mirror port tls)) + (sheet (make-instance 'dummy-context-menu-sheet)) + (menu (make-context-menu port sheet items))) + (gtk_menu_popup menu + (cffi:null-pointer) + (cffi:null-pointer) + (cffi:null-pointer) + (cffi:null-pointer) + 0 + (gtk_get_current_event_time)) + (let ((event (event-read sheet))) + (values (event-value event) (event-itemspec event) event)))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/04/30 10:31:15 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/05/13 19:37:29 1.5 @@ -26,9 +26,18 @@ ((scroll-type :initarg :scroll-type :accessor event-scroll-type) (value :initarg :value :accessor event-value)))
+(defclass menu-clicked-event (gadget-event) + ((item :initarg :item :accessor event-item))) + +(defclass context-menu-clicked-event (gadget-event) + ((value :initarg :value :accessor event-value) + (itemspec :initarg :itemspec :accessor event-itemspec))) +
;;;; Classes
+;; gtk-menu-* see port.lisp + (defclass gtk-button (native-widget-mixin push-button) ())
(defclass gtk-check-button (native-widget-mixin toggle-button) ()) @@ -61,6 +70,9 @@ (gtk-widget-modify-bg button (pane-background sheet))) button))
+(defmethod realize-native-widget ((sheet gtk-menu-bar)) + (gtk_menu_bar_new)) + (defmethod realize-native-widget ((sheet gtk-check-button)) (let ((widget (gtk_check_button_new_with_label (climi::gadget-label sheet)))) (gtk_toggle_button_set_active widget (if (gadget-value sheet) 1 0)) @@ -111,6 +123,94 @@ (if (eq sheet (gadget-value (gadget-client sheet))) 1 0)) result))
+(defun append-menu-items (port sheet menu command-table-name) + (let ((ct (find-command-table command-table-name))) + (dolist (menu-item (slot-value ct 'climi::menu)) + (let ((item (make-native-menu-item port sheet menu-item))) + (gtk_menu_shell_append menu item))))) + +(defun make-native-menu-item (port sheet menu-item) + (ecase (command-menu-item-type menu-item) + (:divider + (gtk_separator_menu_item_new)) + (:command + (let ((item + (gtk_menu_item_new_with_label + (climi::command-menu-item-name menu-item)))) + ;; naja, ein sheet ist das nicht + (setf (widget->sheet item port) menu-item) + (connect-signal item "activate" 'menu-clicked-handler) + item)) + (:menu + (let ((item + (gtk_menu_item_new_with_label + (climi::command-menu-item-name menu-item))) + (menu (gtk_menu_new))) + (setf (widget->sheet item port) sheet) + (setf (widget->sheet menu port) sheet) + (append-menu-items port sheet menu (command-menu-item-value menu-item)) + (gtk_menu_item_set_submenu item menu) + item)))) + +(defun destructure-mc-menu-item (x) + (cond + ((atom x) + (values :item x x nil)) + ((atom (cdr x)) + (values :item (car x) (cdr x) nil)) + (t + (destructuring-bind + (&key value style items documentation active type) + (cdr x) + (declare (ignore style documentation active)) + (values (if items :menu type) + (car x) + (or value (car x)) + items))))) + +;;(defclass dummy-context-menu-sheet (climi::clim-sheet-input-mixin sheet) ()) + +(defclass dummy-context-menu-sheet (climi::standard-sheet-input-mixin sheet) + ()) + +(defclass dummy-menu-item-sheet (sheet) + ((parent :initarg :parent :accessor dummy-menu-item-sheet-parent) + (value :initarg :value :accessor dummy-menu-item-sheet-value) + (itemspec :initarg :itemspec :accessor dummy-menu-item-sheet-itemspec))) + +(defun make-context-menu (port sheet items) + (let ((menu (gtk_menu_new))) + (dolist (itemspec items) + (multiple-value-bind (type display-object value sub-items) + (destructure-mc-menu-item itemspec) + (let* ((label (princ-to-string display-object)) + (gtkmenuitem + (ecase type + (:divider + (gtk_separator_menu_item_new)) + (:label + (gtk_menu_item_new_with_label label)) + (:item + (let ((item + (gtk_menu_item_new_with_label label))) + (setf (widget->sheet item port) + (make-instance 'dummy-menu-item-sheet + :parent sheet + :value value + :itemspec itemspec)) + (connect-signal item + "activate" + 'context-menu-clicked-handler) + item)) + (:menu + (let ((item (gtk_menu_item_new_with_label label)) + (menu (make-context-menu port sheet sub-items))) + (gtk_menu_item_set_submenu item menu) + item))))) + (gtk_menu_shell_append menu gtkmenuitem)))) + (gtk_widget_show_all menu) + menu)) +
;;;; Event definition
@@ -124,6 +224,10 @@ ;; (connect-signal widget "value-changed" 'magic-clicked-handler) (connect-signal widget "change-value" 'scrollbar-change-value-handler))
+(defmethod connect-native-signals ((sheet gtk-menu-bar) widget) + ;; no signals + ) +
;;;; Event handling
@@ -166,6 +270,17 @@ (:page_forward (scroll-down-page-callback pane (gadget-client pane) (gadget-id pane)))))
+(defmethod handle-event + ((pane gtk-menu) (event menu-clicked-event)) + (let ((item (event-item event))) + (ecase (command-menu-item-type item) + (:command + (climi::throw-object-ptype item 'menu-item))))) + +(defmethod handle-event + ((pane gtk-nonmenu) (event magic-gadget-event)) + (funcall (gtk-nonmenu-callback pane) pane nil)) +
;;; COMPOSE-SPACE
@@ -184,6 +299,10 @@ (unless widgetp (gtk_widget_destroy widget)))))
+(defmethod compose-space ((gadget gtk-menu-bar) &key width height) + (declare (ignore width height)) + (make-space-requirement :height 20 :min-height 20 :max-height 20)) +
;;; Vermischtes
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/05/07 14:30:24 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/05/13 19:37:29 1.7 @@ -585,6 +585,46 @@ :pointer (label :string))
+(defcfun "gtk_menu_item_new_with_label" + :pointer + (label :string)) + +(defcfun "gtk_menu_bar_new" + :pointer + ) + +(defcfun "gtk_menu_shell_append" + :void + (menu :pointer) + (item :pointer)) + +(defcfun "gtk_menu_item_set_submenu" + :void + (item :pointer) + (menu :pointer)) + +(defcfun "gtk_menu_new" + :pointer + ) + +(defcfun "gtk_separator_menu_item_new" + :pointer + ) + +(defcfun "gtk_menu_popup" + :void + (menu :pointer) + (parent_menu_shell :pointer) + (parent_menu_item :pointer) + (func :pointer) + (data :pointer) + (button :unsigned-int) + (time :uint32)) + +(defcfun "gtk_get_current_event_time" + :uint32 + ) + (defcfun "gtk_button_set_label" :void (button :pointer) @@ -794,7 +834,7 @@ ;;; foo
(defun test (&optional (port :gtkairo)) - (mapc #'climi::destroy-port climi::*all-ports*) +;;; (mapc #'climi::destroy-port climi::*all-ports*) (setf climi::*server-path-search-order* (list port)) (clim:run-frame-top-level (clim:make-application-frame 'clim-demo::address-book))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/05/01 21:21:39 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/05/13 19:37:29 1.7 @@ -33,7 +33,7 @@ ((port :initarg :port :accessor port) (cr :initform nil :initarg :cr :accessor cr) (flipping-original-cr :initform nil :accessor flipping-original-cr) - (flipping-pixmap :accessor flipping-pixmap) + (flipping-pixmap :initform nil :accessor flipping-pixmap) (surface :initarg :surface :accessor surface) (last-seen-sheet :accessor last-seen-sheet) (last-seen-region :accessor last-seen-region))) @@ -46,12 +46,6 @@ (defclass metrik-medium (gtkairo-medium) ())
-;; FIXME: turn this back on. -;; -;; Disabling antialiasing hides some visual artifacts. Some other -;; artifacts remain around lines that are blurry with antialiasing -;; enabled, which perhaps points to round-off error being the reason for -;; both blurryness and visual artifacts. Both need to be fixed. (defparameter *antialiasingp* t)
(defun gtkwidget-gdkwindow (widget) @@ -86,11 +80,17 @@ (let* ((mirror (medium-mirror medium)) (drawable (mirror-drawable mirror))) (setf (cr medium) (gdk_cairo_create drawable)) - (push medium (mirror-mediums mirror)) + (dispose-flipping-pixmap medium) + (pushnew medium (mirror-mediums mirror)) (cairo_set_antialias (cr medium) (if *antialiasingp* 0 1))) (setf (last-seen-sheet medium) (medium-sheet medium)) (setf (last-seen-region medium) (sheet-region (medium-sheet medium))))))
+(defun dispose-flipping-pixmap (medium) + (when (flipping-pixmap medium) + (gdk_drawable_unref (flipping-pixmap medium)) + (setf (flipping-pixmap medium) nil))) +
;;;; ------------------------------------------------------------------------ ;;;; 8.3 Output Protocol @@ -215,20 +215,19 @@ (to-drawable (medium-gdkdrawable medium))) (cairo_surface_flush from-surface) (cairo_surface_flush to-surface) - (let ((gc (gdk_gc_new to-drawable))) + (let ((gc (gdk_gc_new to-drawable)) + (region (climi::sheet-mirror-region (medium-sheet medium)))) (gdk_gc_set_function gc :xor) - (cffi:with-foreign-slots ((allocation-width allocation-height) - (mirror-widget (medium-mirror medium)) - gtkwidget) - (gdk_draw_drawable to-drawable gc from-drawable 0 0 0 0 - allocation-width allocation-height)) + (gdk_draw_drawable to-drawable gc from-drawable 0 0 0 0 + (floor (bounding-rectangle-max-x region)) + (floor (bounding-rectangle-max-y region))) (gdk_gc_unref gc)) (cairo_surface_mark_dirty to-surface)) (cairo_destroy (cr medium)) (setf (cr medium) (flipping-original-cr medium)) (setf (flipping-original-cr medium) nil) - (gdk_drawable_unref (flipping-pixmap medium)) - (setf (flipping-pixmap medium) nil)) + #+(or win32 mswindows windows) ;fixme + (dispose-flipping-pixmap medium))
(defmethod sync-ink (medium (design climi::standard-flipping-ink)) (setf (flipping-original-cr medium) (cr medium)) @@ -237,11 +236,15 @@ (cffi:with-foreign-slots ((allocation-width allocation-height) (mirror-widget mirror) gtkwidget) - (let ((pixmap - (gdk_pixmap_new drawable allocation-width allocation-height -1))) + (let* ((region (climi::sheet-mirror-region (medium-sheet medium))) + (width (floor (bounding-rectangle-max-x region))) + (height (floor (bounding-rectangle-max-y region))) + (pixmap + (or (flipping-pixmap medium) + (setf (flipping-pixmap medium) + (gdk_pixmap_new drawable width height -1))))) (setf (cr medium) (gdk_cairo_create pixmap)) (cairo_paint (cr medium)) - (setf (flipping-pixmap medium) pixmap) (sync-transformation medium) (sync-ink medium +white+)))))
@@ -348,6 +351,11 @@
;;; text-style
+(defun assert-font-status (cr str) + (let ((status (cairo_font_face_status (cairo_get_font_face cr)))) + (unless (eq status :success) + (error "status ~A after call to ~A" status str)))) + (defun sync-text-style (medium text-style transform-glyphs-p) (with-slots (cr) medium (multiple-value-bind (family face size) @@ -386,6 +394,7 @@ ((:bold :bold-italic :italic-bold :bold-oblique :oblique-bold) :bold))) + (assert-font-status cr "cairo_select_font_face") ;; (cond (transform-glyphs-p (cairo_set_font_size cr (df size))) @@ -403,7 +412,8 @@ ;;; (cairo_matrix_invert matrix) ;;; (cairo_transform_font cr matrix) ;;; )) - ))))) + )) + (assert-font-status cr "cairo_set_font_size"))))
(defun sync-drawing-options (medium) (sync-transformation medium) @@ -609,21 +619,19 @@ (medium-default-text-style medium)) transform-glyphs) (cairo_move_to cr (df x) (df y)) - (cairo_show_text cr (subseq text start end)) ))) + (setf end (or end (length text))) + (unless (eql start end) ;empty string breaks cairo/windows + (cairo_show_text cr (subseq text start end))))))
(defmethod medium-finish-output ((medium gtkairo-medium)) (with-cairo-medium (medium) (when (cr medium) - (cairo_surface_flush (cairo_get_target (cr medium))) -;;; (port-force-output (port medium)) - ))) + (cairo_surface_flush (cairo_get_target (cr medium))))))
(defmethod medium-force-output ((medium gtkairo-medium)) (with-cairo-medium (medium) (when (cr medium) - (cairo_surface_flush (cairo_get_target (cr medium))) -;;; (port-force-output (port medium)) - ))) + (cairo_surface_flush (cairo_get_target (cr medium))))))
(defmethod medium-beep ((medium gtkairo-medium)) ;; fixme: visual beep? @@ -642,6 +650,20 @@ (defmacro slot (o c s) `(cffi:foreign-slot-value ,o ,c ,s))
+(defun cairo-text-extents (cr str res) + (cond + #+(or win32 mswindows windows) ;empty string breaks cairo/windows + ((string= str "") + (setf str " ") + (cairo_text_extents cr str res) + (cffi:with-foreign-slots + ((width x_advance x_bearing) res cairo_text_extents) + (setf width 0.0d0) + (setf x_advance 0.0d0) + (setf x_bearing 0.0d0))) + (t + (cairo_text_extents cr str res)))) +
;;; TEXT-STYLE-ASCENT
@@ -777,9 +799,9 @@ (sync-text-style medium text-style t) (cffi:with-foreign-object (res 'cairo_text_extents) (let (i m) - (cairo_text_extents cr "i" res) + (cairo-text-extents cr "i" res) (setf i (slot res 'cairo_text_extents 'width)) - (cairo_text_extents cr "m" res) + (cairo-text-extents cr "m" res) (setf m (slot res 'cairo_text_extents 'width)) (= i m))))))
@@ -829,7 +851,7 @@ (cairo_identity_matrix cr) (sync-text-style medium text-style t) (cffi:with-foreign-object (res 'cairo_text_extents) - (cairo_text_extents cr + (cairo-text-extents cr (subseq string start (or end (length string))) res) (cffi:with-foreign-slots @@ -859,7 +881,7 @@ (cairo_identity_matrix cr) (sync-text-style medium text-style t) (cffi:with-foreign-object (res 'cairo_text_extents) - (cairo_text_extents cr + (cairo-text-extents cr (subseq string start (or end (length string))) res) ;; This used to be a straight call to TEXT-SIZE. Looking at @@ -965,11 +987,12 @@ (draw-rectangle* medium 0 0 600 600 :ink design)))
;; FIXME: this is some kind of special-purpose function for mediums -;; that aren't intended to be used again. Normal mediums are handled -;; by DESTROY-MEDIUMS. +;; created by MAKE-CAIRO-SURFACE. Normal mediums are handled by +;; DESTROY-MEDIUMS. (defun destroy-cairo-medium (medium) (cairo_destroy (cr medium)) (setf (cr medium) :destroyed) + (dispose-flipping-pixmap medium) (when (surface medium) (cairo_surface_destroy (surface medium))))
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/05/07 19:47:20 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/05/13 19:37:29 1.4 @@ -240,6 +240,22 @@ (defclass native-widget-mixin () ((widget :initform nil :accessor native-widget)))
+(defclass gtk-menu (basic-pane) + ((label :initarg :label :accessor gtk-menu-label) + (command-table :initform nil + :initarg :command-table + :accessor gtk-menu-command-table))) + +(defclass gtk-nonmenu (basic-pane) + ((label :initarg :label :accessor gtk-nonmenu-label) + (callback :initarg :value-changed-callback + :accessor gtk-nonmenu-callback))) + +(defclass gtk-menu-bar (native-widget-mixin + sheet-multiple-child-mixin + basic-pane) + ((contents :initarg :contents :accessor gtk-menu-bar-contents))) + (defmethod realize-mirror ((port gtkairo-port) (sheet native-widget-mixin)) (with-gtk () (setf (native-widget sheet) (realize-native-widget sheet)) @@ -268,6 +284,51 @@ (gtk_widget_show_all fixed)) mirror)))
+(defclass menu-mirror (widget-mirror) + ((menu-item :initarg :menu-item :reader mirror-menu-item) + (menu :initarg :menu :reader mirror-menu))) + +(defclass nonmenu-mirror (widget-mirror) + ((menu-item :initarg :menu-item :reader mirror-menu-item))) + +(defmethod realize-mirror :after ((port gtkairo-port) (sheet gtk-menu-bar)) + (dolist (menu (gtk-menu-bar-contents sheet)) + (unless (integerp menu) ;? + (sheet-adopt-child sheet menu)))) + +(defmethod realize-mirror ((port gtkairo-port) (sheet gtk-menu)) + (unless (climi::port-lookup-mirror port sheet) + (with-gtk () + (let* ((menu-item (gtk_menu_item_new_with_label (gtk-menu-label sheet))) + (menu (gtk_menu_new)) + (parent (sheet-mirror (sheet-parent sheet))) + (mirror + (make-instance 'menu-mirror :menu menu :menu-item menu-item))) + (setf (widget->sheet menu-item port) sheet) + (setf (widget->sheet menu port) sheet) + (append-menu-items port sheet menu (gtk-menu-command-table sheet)) + (gtk_menu_item_set_submenu menu-item menu) + (gtk_menu_shell_append (mirror-widget parent) menu-item) + (climi::port-register-mirror (port sheet) sheet mirror) + (when (sheet-enabled-p sheet) + (gtk_widget_show_all menu-item)) + mirror)))) + +(defmethod realize-mirror ((port gtkairo-port) (sheet gtk-nonmenu)) + (unless (climi::port-lookup-mirror port sheet) + (with-gtk () + (let* ((menu-item + (gtk_menu_item_new_with_label (gtk-nonmenu-label sheet))) + (parent (sheet-mirror (sheet-parent sheet))) + (mirror (make-instance 'nonmenu-mirror :menu-item menu-item))) + (setf (widget->sheet menu-item port) sheet) + (connect-signal menu-item "activate" 'magic-clicked-handler) + (gtk_menu_shell_append (mirror-widget parent) menu-item) + (climi::port-register-mirror (port sheet) sheet mirror) + (when (sheet-enabled-p sheet) + (gtk_widget_show_all menu-item)) + mirror)))) + (defmethod realize-mirror ((port gtkairo-port) (pixmap-sheet climi::pixmap)) (unless (climi::port-lookup-mirror port pixmap-sheet) (let* ((drawable @@ -298,7 +359,8 @@ (dolist (medium (mirror-mediums mirror)) (when (cr medium) (cairo_destroy (cr medium)) - (setf (cr medium) nil))) + (setf (cr medium) nil) + (dispose-flipping-pixmap medium))) (setf (mirror-mediums mirror) '()))
(defmethod destroy-mirror @@ -329,6 +391,18 @@ (gdk_drawable_unref (mirror-drawable mirror)) (climi::port-unregister-mirror port pixmap-sheet mirror)))))
+(defmethod destroy-mirror ((port gtkairo-port) (pixmap-sheet gtk-menu)) + (with-gtk () + (let ((mirror (climi::port-lookup-mirror port pixmap-sheet))) + (when mirror + (climi::port-unregister-mirror port pixmap-sheet mirror))))) + +(defmethod destroy-mirror ((port gtkairo-port) (pixmap-sheet gtk-nonmenu)) + (with-gtk () + (let ((mirror (climi::port-lookup-mirror port pixmap-sheet))) + (when mirror + (climi::port-unregister-mirror port pixmap-sheet mirror))))) +
;;;; Positioning and resizing