mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 13 May '06

13 May '06

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

1 0

[mcclim-cvs] CVS mcclim
by dlichteblau 13 May '06

13 May '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv8095 Modified Files: menu.lisp Log Message: Oops, don't allow the menu bar to get smaller on resizes. * menu.lisp ((compose-space menu-bar)): Specify min-height. --- /project/mcclim/cvsroot/mcclim/menu.lisp 2006/05/13 00:03:41 1.35 +++ /project/mcclim/cvsroot/mcclim/menu.lisp 2006/05/13 00:19:36 1.36 @@ -390,8 +390,9 @@ (defmethod compose-space ((pane menu-bar) &key width height) (declare (ignore width height)) - (space-requirement+ (call-next-method) - (make-space-requirement :height 4 :max-height 4))) + (space-requirement+ + (call-next-method) + (make-space-requirement :height 4 :max-height 4 :min-height 4))) (defmethod box-layout-mixin/horizontally-allocate-space ((pane menu-bar) real-width real-height)

1 0

[mcclim-cvs] CVS mcclim
by dlichteblau 13 May '06

13 May '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5661 Modified Files: menu.lisp Log Message: Hack the MENU-BAR to draw its own 3d effect instead of wrapping a RAISED-PANE around it. This way the frame manager gets to decide on the appearance of the menu bar. * menu.lisp (MAKE-MENU-BAR): Don't wrap the menu bar pane in a raising. (HANDLE-REPAINT, COMPOSE-SPACE, BOX-LAYOUT-MIXIN/HORIZONTALLY-ALLOCATE-SPACE): New methods on menu-bar. --- /project/mcclim/cvsroot/mcclim/menu.lisp 2004/11/07 19:33:31 1.34 +++ /project/mcclim/cvsroot/mcclim/menu.lisp 2006/05/13 00:03:41 1.35 @@ -362,20 +362,55 @@ (max-width +fill+) max-height min-width min-height) (with-slots (menu) (find-command-table command-table) - (raising () - (make-pane-1 *pane-realizer* *application-frame* - 'menu-bar - :background *3d-normal-color* - :width width :height height - :max-width max-width :max-height max-height - :min-width min-width :min-height min-height - :contents - (append - (loop for item in menu - collect - (make-menu-button-from-menu-item - item nil - :bottomp t - :vertical nil - :command-table command-table)) - (list +fill+)))))) + (make-pane-1 *pane-realizer* *application-frame* + 'menu-bar + :background *3d-normal-color* + :width width :height height + :max-width max-width :max-height max-height + :min-width min-width :min-height min-height + :contents + (append + (loop for item in menu + collect + (make-menu-button-from-menu-item + item nil + :bottomp t + :vertical nil + :command-table command-table)) + (list +fill+))))) + +(defmethod handle-repaint ((pane menu-bar) region) + (declare (ignore region)) + (with-slots (border-width) pane + (multiple-value-call #'draw-bordered-rectangle* + pane + (bounding-rectangle* (sheet-region pane)) + :style :outset + :border-width 2))) + +(defmethod compose-space ((pane menu-bar) &key width height) + (declare (ignore width height)) + (space-requirement+ (call-next-method) + (make-space-requirement :height 4 :max-height 4))) + +(defmethod box-layout-mixin/horizontally-allocate-space + ((pane menu-bar) real-width real-height) + (with-slots (x-spacing) pane + (let ((widths + (box-layout-mixin/horizontally-allocate-space-aux* + pane real-width real-height)) + (x 2)) + (loop + for child in (box-layout-mixin-clients pane) + for width in widths + do + (when (box-client-pane child) + (layout-child (box-client-pane child) + :expand + :expand + x + 2 + width + (- real-height 4))) + (incf x width) + (incf x x-spacing)))))

1 0

[mcclim-cvs] CVS mcclim/Examples
by dlichteblau 12 May '06

12 May '06

Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv27703 Modified Files: demodemo.lisp Log Message: * demodemo.lisp (demodemo): Removed the empty menu bar. --- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/05/07 19:47:19 1.11 +++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/05/12 22:40:51 1.12 @@ -43,6 +43,7 @@ (define-application-frame demodemo () () + (:menu-bar nil) (:layouts (default (vertically (:equalize-width t)

1 0

[mcclim-cvs] CVS mcclim
by crhodes 12 May '06

12 May '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv17798 Modified Files: commands.lisp Log Message: In accepting command names textually, suggest only one command per string name, and suggest ones from the child tables in preference. This allows command shadowing to behave as you might expect. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2006/04/21 12:03:23 1.62 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2006/05/12 10:24:32 1.63 @@ -1090,11 +1090,15 @@ &key) (flet ((generator (string suggester) (declare (ignore string)) - (map-over-command-table-names - (lambda (cline-name command-name) - (when (command-enabled command-name *application-frame*) - (funcall suggester cline-name command-name))) - command-table))) + (let ((possibilities nil)) + (map-over-command-table-names + (lambda (cline-name command-name) + (when (command-enabled command-name *application-frame*) + (pushnew (cons cline-name command-name) possibilities + :key #'car :test #'string=))) + command-table) + (loop for (cline-name . command-name) in possibilities + do (funcall suggester cline-name command-name))))) ;; Bind the frame's command table so that the command-enabled ;; test passes with this command table. (letf (((frame-command-table *application-frame*)

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by crhodes 10 May '06

10 May '06

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv10114 Modified Files: listener.lisp Log Message: Note a problem with the execute-frame-command method --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/03/29 10:43:37 1.25 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/05/10 11:19:33 1.26 @@ -121,6 +121,7 @@ (history-length :initform 25 :initarg :history-length :accessor history-length))) (defmethod execute-frame-command :after ((frame command-history-mixin) command) + ;; FIXME: not safe against commands sent from other frames. (push command (history frame)) (when (> (length (history frame)) (history-length frame)) (setf (history frame)

1 0

[mcclim-cvs] CVS mcclim
by crhodes 10 May '06

10 May '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv10052 Modified Files: presentation-defs.lisp Log Message: typo-in-comment fix --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/05/05 10:24:02 1.56 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/05/10 11:18:42 1.57 @@ -841,7 +841,7 @@ :default-type default-type) (funcall-presentation-generic-function accept type stream view)))) - ;; User entered activation or delimeter + ;; User entered activation or delimiter ;; gesture without any input. (if defaultp (progn

1 0

[mcclim-cvs] CVS mcclim/Examples
by dlichteblau 09 May '06

09 May '06

Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv22236 Modified Files: drawing-benchmark.lisp text-size-test.lisp Log Message: * text-size-test.lisp (com-update): Renamed to com-update-text-size-test. * drawing-benchmark.lisp (com-update): Renamed to com-run-drawing-benchmark. --- /project/mcclim/cvsroot/mcclim/Examples/drawing-benchmark.lisp 2006/05/07 19:47:19 1.1 +++ /project/mcclim/cvsroot/mcclim/Examples/drawing-benchmark.lisp 2006/05/09 20:07:54 1.2 @@ -90,6 +90,6 @@ (define-drawing-benchmark-command (com-quit-drawing-benchmark :menu "Quit") () (frame-exit *application-frame*)) -(define-drawing-benchmark-command (com-update :menu "Run") () +(define-drawing-benchmark-command (com-run-drawing-benchmark :menu "Run") () (run-drawing-benchmark *application-frame* (frame-standard-output *application-frame*))) --- /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/04/19 11:43:31 1.2 +++ /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/05/09 20:07:54 1.3 @@ -109,6 +109,6 @@ (define-text-size-test-command (com-quit-text-size-test :menu "Quit") () (frame-exit *application-frame*)) -(define-text-size-test-command (com-update :menu "Update") () +(define-text-size-test-command (com-update-text-size-test :menu "Update") () (display-canvas *application-frame* (frame-standard-output *application-frame*)))

1 0

[mcclim-cvs] CVS mcclim/Goatee
by crhodes 09 May '06

09 May '06

Update of /project/mcclim/cvsroot/mcclim/Goatee In directory clnet:/tmp/cvs-serv3467 Modified Files: clim-area.lisp Log Message: The commit on 2006-03-01 to clim-area claimed to add space for a visible cursor, but in fact added space for a cursor whether visible or not. Only add in the space for visible cursors. This fixes most of the text glitches in the clim listener; now where previously e.g. (* 2 3) RET would leave an extra space at the end of the bounding rectangle, the text is tightly bound. *package* RET still has a problem, as the RET there seems to open a new (empty) screen line. --- /project/mcclim/cvsroot/mcclim/Goatee/clim-area.lisp 2006/04/01 07:58:37 1.33 +++ /project/mcclim/cvsroot/mcclim/Goatee/clim-area.lisp 2006/05/09 14:01:09 1.34 @@ -219,11 +219,11 @@ (let ((cursor (cursor record))) (multiple-value-bind (x1 y1 x2 y2) (call-next-method) (values x1 y1 - (if cursor + (if (and cursor (eq (cursor-visibility cursor) :on)) (with-slots (climi::x climi::width) cursor (max x2 (+ climi::x climi::width))) x2) - (if cursor + (if (and cursor (eq (cursor-visibility cursor) :on)) (max y2 (+ y1 (climi::cursor-height cursor))) y2)))))

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 07 May '06

07 May '06

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv26624/Backends/gtkairo Modified Files: port.lisp Log Message: Medium benchmark toy. * mcclim.asd (clim-examples): Added drawing-benchmark.lisp. * Examples/drawing-benchmark.lisp: New file. * Examples/demodemo.lisp (demodemo): Added Drawing Benchmark button. * Backends/gtkairo/port.lisp (port-force-output): Call gdk_flush. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/04/23 10:18:45 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/05/07 19:47:20 1.3 @@ -581,7 +581,11 @@ (defmethod port-force-output ((port gtkairo-port)) (with-gtk () - (gdk_display_flush (gdk_display_get_default)))) + (gdk_display_flush (gdk_display_get_default)) + ;; Don't know whether p-f-o is actually meant to XSync, which is + ;; what gdk_flush does. But it seems useful to have _some_ function + ;; for this, so let's use p-f-o until we find a better one. + (gdk_flush))) ;; FIXME: What happens when CLIM code calls tracking-pointer recursively? (defmethod port-grab-pointer ((port gtkairo-port) pointer sheet)

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs