[mcclim-cvs] CVS mcclim

[thenriksen]

Update of /project/mcclim/cvsroot/mcclim
In directory cl-net:/tmp/cvs-serv10938

Modified Files:
	commands.lisp 
Log Message:
MAP-OVER-COMMAND-TABLE-TRANSLATORS and
ADD-ACTUAL-PRESENTATION-TRANSLATOR-TO-COMMAND-TABLE from Mike Watters.


--- /project/mcclim/cvsroot/mcclim/commands.lisp	2008/04/20 07:19:10	1.79
+++ /project/mcclim/cvsroot/mcclim/commands.lisp	2008/10/23 20:49:41	1.80
@@ -480,6 +480,39 @@
           (map-over-command-table-menu-items function table))))
     (values)))
 
+(defun map-over-command-table-translators
+    (function command-table &key (inherited t))
+  (flet ((map-func (table)
+           (maphash #'(lambda (k v)
+                        (declare (ignore k))
+                        (funcall function v))
+                    (slot-value
+                     (presentation-translators table)
+                     'translators))))
+    (let ((command-table (find-command-table command-table)))
+      (if inherited
+          (apply-with-command-table-inheritance #'map-func command-table)
+          (map-func command-table)))))
+
+;(defun add-presentation-translator-to-command-table
+;    (command-table translator-name &key (errorp t)))
+; - fixme; spec says this fun is given a translator name, but that
+; find-presentation-translator needs a translator name and a command
+; table designator
+(defun add-actual-presentation-translator-to-command-table
+    (command-table translator &key (errorp t))
+  (let ((translators
+         (presentation-translators
+          (find-command-table command-table))))
+    (when (and errorp
+               (second
+                (multiple-value-list
+                 (gethash (name translator)
+                          (slot-value translators 'translators)))))
+      (error 'command-already-present
+       :command-table-name command-table))
+    (add-translator translators translator)))
+
 ;; At this point we should still see the gesture name as supplied by the
 ;; programmer in 'gesture'
 (defun %add-keystroke-item (command-table gesture item errorp)