Mercurial > hg > xemacs-beta

comparison lisp/prim/menubar.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 0293115a14e9
children 2d532a89d707
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 ;; General Public License for more details. 16 ;; General Public License for more details.
17 17
18 ;; You should have received a copy of the GNU General Public License 18 ;; You should have received a copy of the GNU General Public License
19 ;; along with XEmacs; see the file COPYING. If not, write to the 19 ;; along with XEmacs; see the file COPYING. If not, write to the
20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 20 ;; Free Software Foundation, 59 Temple Place - Suite 330,
21 ;; Boston, MA 02111-1307, USA. 21 ;; Boston, MA 02111-1307, USA.
22 22
23 ;;; Synched up with: Not in FSF. (Completely divergent from FSF menu-bar.el) 23 ;;; Synched up with: Not in FSF. (Completely divergent from FSF menu-bar.el)
24 ;;; Some stuff in FSF menu-bar.el is in x-menubar.el 24 ;;; Some stuff in FSF menu-bar.el is in x-menubar.el
25 25
194 (signal 'error (list (gettext "not a submenu") result)) 194 (signal 'error (list (gettext "not a submenu") result))
195 (signal 'error (list (gettext "no such submenu") (car item-path-list))))) 195 (signal 'error (list (gettext "no such submenu") (car item-path-list)))))
196 (cons result parent))))) 196 (cons result parent)))))
197 197
198 (defun add-menu-item-1 (leaf-p menu-path new-item before) 198 (defun add-menu-item-1 (leaf-p menu-path new-item before)
199 (if before (setq before (downcase before))) 199 ;; This code looks like it could be cleaned up some more
200 (let* ((item-name (if (vectorp new-item) (aref new-item 0) (car new-item))) 200 ;; Do we really need 6 calls to find-menu-item?
201 (when before (setq before (downcase before)))
202 (let* ((item-name
203 (cond ((vectorp new-item) (aref new-item 0))
204 ((consp new-item) (car new-item))
205 (t nil)))
201 (menubar current-menubar) 206 (menubar current-menubar)
202 (menu (condition-case () 207 (menu (condition-case ()
203 (car (find-menu-item menubar menu-path)) 208 (car (find-menu-item menubar menu-path))
204 (error nil))) 209 (error nil)))
205 (item-found (cond ((not (listp menu)) 210 (item-found (cond
206 (signal 'error (list (gettext "not a submenu") 211 ((null item-name)
207 menu-path))) 212 nil)
208 (menu 213 ((not (listp menu))
209 (find-menu-item (cdr menu) (list item-name))) 214 (signal 'error (list (gettext "not a submenu")
210 (t 215 menu-path)))
211 (find-menu-item menubar (list item-name))) 216 (menu
212 ))) 217 (find-menu-item (cdr menu) (list item-name)))
213 (or menubar 218 (t
214 (error "`current-menubar' is nil: can't add menus to it.")) 219 (find-menu-item menubar (list item-name)))
215 (or menu 220 )))
216 (let ((rest menu-path) 221 (unless menubar
217 (so-far menubar)) 222 (error "`current-menubar' is nil: can't add menus to it."))
218 (while rest 223 (unless menu
219 ;;; (setq menu (car (find-menu-item (cdr so-far) (list (car rest))))) 224 (let ((rest menu-path)
220 (setq menu 225 (so-far menubar))
221 (if (eq so-far menubar) 226 (while rest
222 (car (find-menu-item so-far (list (car rest)))) 227 ;;; (setq menu (car (find-menu-item (cdr so-far) (list (car rest)))))
223 (car (find-menu-item (cdr so-far) (list (car rest)))))) 228 (setq menu
224 (or menu 229 (if (eq so-far menubar)
225 (let ((rest2 so-far)) 230 (car (find-menu-item so-far (list (car rest))))
226 (while (and (cdr rest2) (car (cdr rest2))) 231 (car (find-menu-item (cdr so-far) (list (car rest))))))
227 (setq rest2 (cdr rest2))) 232 (unless menu
228 (setcdr rest2 233 (let ((rest2 so-far))
229 (nconc (list (setq menu (list (car rest)))) 234 (while (and (cdr rest2) (car (cdr rest2)))
230 (cdr rest2))))) 235 (setq rest2 (cdr rest2)))
231 (setq so-far menu) 236 (setcdr rest2
232 (setq rest (cdr rest))))) 237 (nconc (list (setq menu (list (car rest))))
238 (cdr rest2)))))
239 (setq so-far menu)
240 (setq rest (cdr rest)))))
233 (if (and item-found (car item-found)) 241 (if (and item-found (car item-found))
234 ;; hack the item in place. 242 ;; hack the item in place.
235 (if menu 243 (if menu
244 ;; Isn't it very bad form to use nsubstitute for side effects?
236 (nsubstitute new-item (car item-found) menu) 245 (nsubstitute new-item (car item-found) menu)
237 (setq current-menubar (nsubstitute new-item 246 (setq current-menubar (nsubstitute new-item
238 (car item-found) 247 (car item-found)
239 current-menubar))) 248 current-menubar)))
240 ;; OK, we have to add the whole thing... 249 ;; OK, we have to add the whole thing...
241 ;; if BEFORE is specified, try to add it there. 250 ;; if BEFORE is specified, try to add it there.
242 (or menu (setq menu current-menubar)) 251 (unless menu (setq menu current-menubar))
243 (if before 252 (when before
244 (setq before (car (find-menu-item menu (list before))))) 253 (setq before (car (find-menu-item menu (list before)))))
245 (let ((rest menu) 254 (let ((rest menu)
246 (added-before nil)) 255 (added-before nil))
247 (while rest 256 (while rest
248 (if (eq before (car (cdr rest))) 257 (if (eq before (car (cdr rest)))
249 (progn 258 (progn
250 (setcdr rest (cons new-item (cdr rest))) 259 (setcdr rest (cons new-item (cdr rest)))
251 (setq rest nil added-before t)) 260 (setq rest nil added-before t))
252 (setq rest (cdr rest)))) 261 (setq rest (cdr rest))))
253 (if (not added-before) 262 (when (not added-before)
254 ;; adding before the first item on the menubar itself is harder 263 ;; adding before the first item on the menubar itself is harder
255 (if (and (eq menu menubar) (eq before (car menu))) 264 (if (and (eq menu menubar) (eq before (car menu)))
256 (setq menu (cons new-item menu) 265 (setq menu (cons new-item menu)
257 current-menubar menu) 266 current-menubar menu)
258 ;; otherwise, add the item to the end. 267 ;; otherwise, add the item to the end.
259 (nconc menu (list new-item)))))) 268 (nconc menu (list new-item))))))
260 (set-menubar-dirty-flag) 269 (set-menubar-dirty-flag)
261 new-item)) 270 new-item))
262 271
263 (defun add-menu-button (menu-path menu-leaf &optional before) 272 (defun add-menu-button (menu-path menu-leaf &optional before)
264 "Add a menu item to some menu, creating the menu first if necessary. 273 "Add a menu item to some menu, creating the menu first if necessary.