[mcclim-cvs] CVS mcclim/Backends/gtkairo - mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

12 Nov 2006

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo
In directory clnet:/tmp/cvs-serv21118
Modified Files:
    frame-manager.lisp gadgets.lisp 
Log Message:
Print context menu items properly.
* frame-manager.lisp (frame-manager-menu-choose): Pass PRINTER to
    MAKE-CONTEXT-MENU.
    
    * gadgets.lisp (make-context-menu): Use new argument PRINTER, or
    PRINT-MENU-ITEM, instead of PRINC-TO-STRING.

--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp	2006/11/12 20:12:19	1.6
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp	2006/11/12 20:37:14	1.7
@@ -129,7 +129,7 @@
      cell-align-x cell-align-y scroll-bars pointer-documentation)
   (declare
    ;; XXX hallo?
-   (ignore printer presentation-type default-item default-item-p
+   (ignore 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
@@ -139,7 +139,7 @@
    	    *application-frame*))
     (port (port frame))
     (sheet (make-instance 'dummy-context-menu-sheet))
-	 (menu (make-context-menu port sheet items)))
+	 (menu (make-context-menu port sheet items :printer printer)))
     (invoke-later
      (lambda ()
        (invoke-later (lambda () (gdk_pointer_ungrab GDK_CURRENT_TIME)))
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp	2006/11/12 20:12:19	1.8
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp	2006/11/12 20:37:14	1.9
@@ -284,12 +284,15 @@
      (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)
+(defun make-context-menu (port sheet items &key printer)
   (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))
+	(let* ((label (with-output-to-string (s)
+			(funcall (or printer #'print-menu-item)
+				 display-object
+				 s)))
           (gtkmenuitem
    	(ecase type
    	  (:divider

    