[mcclim-cvs] CVS mcclim
thenriksen
thenriksen at common-lisp.net
Tue Jan 29 19:13:08 UTC 2008
Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv14257
Modified Files:
NEWS commands.lisp menu.lisp
Log Message:
Implemented :inherit-menu keyword argument for MAKE-COMMAND-TABLE and DEFINE-COMMAND-TABLE.
--- /project/mcclim/cvsroot/mcclim/NEWS 2008/01/26 11:33:02 1.32
+++ /project/mcclim/cvsroot/mcclim/NEWS 2008/01/29 19:13:07 1.33
@@ -18,6 +18,9 @@
** Bug fix: ellipses with a zero radius no longer cause errors.
** Bug fix: bezier drawing in CLIM-FIG less likely to cause errors.
** Bug fix: restored somewhat working undo in CLIM-FIG.
+** Specification compliance: The :inherit-menu keyword argument to
+ DEFINE-COMMAND-TABLE and MAKE-COMMAND-TABLE is now implemented with
+ CLIM 2.2 semantics. The :keystrokes value is not handled yet.
* Changes in mcclim-0.9.5 relative to 0.9.4:
** Installation: the systems clim-listener, clim-examples,
--- /project/mcclim/cvsroot/mcclim/commands.lisp 2008/01/22 08:51:02 1.73
+++ /project/mcclim/cvsroot/mcclim/commands.lisp 2008/01/29 19:13:07 1.74
@@ -77,6 +77,13 @@
:initform (make-hash-table :test #'equal))
(presentation-translators :reader presentation-translators
:initform (make-instance 'translator-table))
+ (inherit-menu :reader inherit-menu
+ :initform nil
+ ;; We interpret :menu to mean "inherit menu items
+ ;; without keystrokes" and :keystrokes to mean
+ ;; "inherit menu items with keystrokes".
+ :type (member nil t :menu :keystrokes)
+ :initarg :inherit-menu)
(menu :initarg :menu :initform '())
(keystroke-accelerators :initform nil)
(keystroke-items :initform nil)))
@@ -85,6 +92,12 @@
(print-unreadable-object (table stream :identity t :type t)
(format stream "~S" (command-table-name table))))
+;;; We store command-table designators, but this function should
+;;; return command table objects.
+(defmethod command-table-inherit-from :around
+ ((command-table standard-command-table))
+ (mapcar #'find-command-table (call-next-method)))
+
;;; Franz user manual says that this slot is setf-able
(defgeneric (setf command-table-inherit-from) (inherit-from table))
@@ -93,6 +106,20 @@
(invalidate-translator-caches)
(setf (slot-value table 'inherit-from) inherit))
+(defun inherit-keystrokes (command-table)
+ "Return true if `command-table' (which must be a command table
+designator) inherits keystrokes."
+ (let ((inherit-menu (inherit-menu (find-command-table command-table))))
+ (or (eq inherit-menu t)
+ (eq inherit-menu :keystrokes))))
+
+(defun inherit-menu-items (command-table)
+ "Return true if `command-table' (which must be a command table
+designator) inherits menu items."
+ (let ((inherit-menu (inherit-menu (find-command-table command-table))))
+ (or (inherit-keystrokes command-table)
+ (eq inherit-menu :menu))))
+
(defparameter *command-tables* (make-hash-table :test #'eq))
(define-condition command-table-error (simple-error)
@@ -174,13 +201,14 @@
:menu nil))
; adjusted to allow anonymous command-tables for menu-bars
-(defun make-command-table (name &key inherit-from menu (errorp t))
+(defun make-command-table (name &key inherit-from menu inherit-menu (errorp t))
(unless inherit-from
(setq inherit-from '(global-command-table)))
(if (and name errorp (gethash name *command-tables*))
(error 'command-table-already-exists :command-table-name name)
(let ((result (make-instance 'standard-command-table :name name
:inherit-from inherit-from
+ :inherit-menu inherit-menu
:menu (menu-items-from-list menu))))
(when name
(setf (gethash name *command-tables*) result))
@@ -188,7 +216,7 @@
(make-command-table 'user-command-table)
-(defmacro define-command-table (name &key inherit-from menu)
+(defmacro define-command-table (name &key inherit-from menu inherit-menu)
`(let ((old-table (gethash ',name *command-tables* nil))
(inherit-from-arg (or ',inherit-from '(global-command-table))))
(if old-table
@@ -198,6 +226,7 @@
old-table)
(make-command-table ',name
:inherit-from inherit-from-arg
+ :inherit-menu ,inherit-menu
:menu ',menu
:errorp nil))))
@@ -338,11 +367,15 @@
(defun find-menu-item (menu-name command-table &key (errorp t))
(let* ((table (find-command-table command-table))
(mem (member menu-name (slot-value table 'menu)
- :key #'command-menu-item-name :test #'string-equal)))
- (cond (mem (values (car mem) command-table))
- (errorp (error 'command-not-accessible :command-table-name
- (command-table-designator-as-name table)))
- (t nil))))
+ :key #'command-menu-item-name :test #'string-equal)))
+ (if mem
+ (values (car mem) command-table)
+ (or (find-if #'(lambda (table)
+ (find-menu-item menu-name table :errorp nil))
+ (command-table-inherit-from table))
+ (when errorp
+ (error 'command-not-accessible :command-table-name
+ (command-table-designator-as-name table)))))))
(defun remove-menu-item-from-command-table (command-table string
&key (errorp t))
@@ -415,14 +448,34 @@
after)))
(defun map-over-command-table-menu-items (function command-table)
- (mapc #'(lambda (item)
- (with-slots (menu-name keystroke) item
- (funcall function
- menu-name
- (and (slot-boundp item 'keystroke) keystroke)
- item)))
- (slot-value (find-command-table command-table) 'menu))
- (values))
+ "Applies function to all of the items in `command-table's
+menu. `Command-table' must be a command table or the name of a
+command table. `Function' must be a function of three arguments,
+the menu name, the keystroke accelerator gesture (which will be
+NIL if there is none), and the command menu item; it has dynamic
+extent. The command menu items are mapped over in the order
+specified by `add-menu-item-to-command-table'. `Command-table' is
+a command table designator. Any inherited menu items will be
+mapped over after `command-table's own menu items.
+
+`Map-over-command-table-menu-items' does not descend into
+sub-menus. If the programmer requires this behavior, he should
+examine the type of the command menu item to see if it is
+`:menu'."
+ (let ((table-object (find-command-table command-table)))
+ (flet ((map-table-entries (table)
+ (mapc #'(lambda (item)
+ (with-slots (menu-name keystroke) item
+ (funcall function
+ menu-name
+ (and (slot-boundp item 'keystroke) keystroke)
+ item)))
+ (slot-value table 'menu))))
+ (map-table-entries table-object)
+ (when (inherit-menu-items table-object)
+ (dolist (table (command-table-inherit-from table-object))
+ (map-over-command-table-menu-items function table))))
+ (values)))
;; At this point we should still see the gesture name as supplied by the
;; programmer in 'gesture'
--- /project/mcclim/cvsroot/mcclim/menu.lisp 2006/12/23 11:52:27 1.38
+++ /project/mcclim/cvsroot/mcclim/menu.lisp 2008/01/29 19:13:07 1.39
@@ -125,15 +125,25 @@
()
(:default-initargs :border-width 2 :background *3d-normal-color*))
+(defun make-menu-buttons (command-table-name client)
+ "Map over the available menu items in the command table with
+name `command-table-name', taking inherited menu items into
+account, and create a list of menu buttons."
+ (let ((menu-buttons '()))
+ (map-over-command-table-menu-items
+ #'(lambda (name gesture item)
+ (declare (ignore name gesture))
+ (push (make-menu-button-from-menu-item
+ item client :command-table command-table-name :vertical t)
+ menu-buttons))
+ command-table-name)
+ (nreverse menu-buttons)))
+
(defun create-substructure (sub-menu client)
(let* ((frame *application-frame*)
(manager (frame-manager frame))
(command-table-name (slot-value sub-menu 'command-table))
- (items (mapcar #'(lambda (item)
- (make-menu-button-from-menu-item
- item client :command-table command-table-name :vertical t))
- (slot-value (find-command-table command-table-name)
- 'menu)))
+ (items (make-menu-buttons command-table-name client))
(rack (make-pane-1 manager frame 'vrack-pane
:background *3d-normal-color* :contents items))
(raised (make-pane-1 manager frame 'submenu-border :contents (list rack))))
More information about the Mcclim-cvs
mailing list