[mcclim-cvs] CVS mcclim

[thenriksen]

Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv8176

Modified Files:
	commands.lisp 
Log Message:
Added portable implementation of `display-command-table-menu'.


--- /project/mcclim/cvsroot/mcclim/commands.lisp	2006/11/08 01:18:22	1.65
+++ /project/mcclim/cvsroot/mcclim/commands.lisp	2006/12/13 22:30:31	1.66
@@ -541,6 +541,35 @@
 	      gesture))
 	gesture)))
 
+(defmethod display-command-table-menu ((command-table standard-command-table)
+                                       (stream fundamental-output-stream)
+                                       &rest args
+                                       &key max-width max-height n-rows n-columns
+                                       x-spacing y-spacing initial-spacing
+                                       row-wise (cell-align-x :left)
+                                       (cell-align-y :top) (move-cursor t))
+  (formatting-item-list (stream :max-width max-width :max-height max-height :n-rows n-rows
+                                :n-columns n-columns :x-spacing x-spacing :y-spacing y-spacing
+                                :initial-spacing initial-spacing :row-wise row-wise
+                                :move-cursor move-cursor)
+    (map-over-command-table-menu-items
+     #'(lambda (item-name accelerator item)
+         (declare (ignore accelerator))
+         (formatting-cell (stream :align-x cell-align-x :align-y cell-align-y)
+           (cond ((eq (command-menu-item-type item) :menu)
+                  (with-text-style (stream (make-text-style :serif '(:bold :italic) nil))
+                    (write-string item-name stream)
+                    (terpri stream))
+                  (surrounding-output-with-border (stream)
+                   (apply #'display-command-table-menu
+                          (find-command-table (command-menu-item-value item))
+                          stream args)))
+                 ((eq (command-menu-item-type item) :command)
+                  (let ((name (command-name (command-menu-item-value item))))
+                   (when (command-line-name-for-command name command-table :errorp nil)
+                     (present name 'command-name :stream stream)))))))
+     command-table)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; Commands