[mcclim-cvs] CVS mcclim/Backends/gtkairo
dlichteblau
dlichteblau at common-lisp.net
Sat May 13 19:37:29 UTC 2006
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 , at 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
More information about the Mcclim-cvs
mailing list