Mercurial > hg > xemacs-beta
comparison lisp/menubar.el @ 5780:580ebed3500a
Bug fix in menubar.el
2013-12-30 Byrel Mitchell <byrel.mitchell@gmail.com>
* menubar.el (add-menu-item-1, delete-menu-item): Do not assume
every top-level menu is on current-menubar.
| author | Mike Sperber <sperber@deinprogramm.de> |
|---|---|
| date | Sat, 18 Jan 2014 17:40:41 +0100 |
| parents | 68f8d295be49 |
| children |
comparison
equal
deleted
inserted
replaced
| 5779:e9d0228c5671 | 5780:580ebed3500a |
|---|---|
| 231 (t | 231 (t |
| 232 (find-menu-item menubar (list item-name))) | 232 (find-menu-item menubar (list item-name))) |
| 233 ))) | 233 ))) |
| 234 (unless menubar | 234 (unless menubar |
| 235 (error "`current-menubar' is nil: can't add menus to it.")) | 235 (error "`current-menubar' is nil: can't add menus to it.")) |
| 236 (unless menu | 236 (unless menu ; If we don't have all intervening submenus needed by menu-path, add them. |
| 237 (let ((rest menu-path) | 237 (let ((rest menu-path) |
| 238 (so-far menubar)) | 238 (so-far menubar)) |
| 239 (while rest | 239 (while rest |
| 240 ;;; (setq menu (car (find-menu-item (cdr so-far) (list (car rest))))) | 240 ;;; (setq menu (car (find-menu-item (cdr so-far) (list (car rest))))) |
| 241 (setq menu | 241 (setq menu |
| 242 (if (eq so-far menubar) | 242 (if (eq so-far menubar) |
| 243 (car (find-menu-item so-far (list (car rest)))) | 243 (car (find-menu-item so-far (list (car rest)))) |
| 244 (car (find-menu-item (cdr so-far) (list (car rest)))))) | 244 (car (find-menu-item (cdr so-far) (list (car rest)))))) |
| 245 (unless menu | 245 (unless menu |
| 246 (let ((rest2 so-far)) | 246 (let ((rest2 so-far)) |
| 247 (while (and (cdr rest2) (car (cdr rest2))) | 247 (while (and (cdr rest2) (car (cdr rest2))) ; Walk rest2 down so-far till rest2 is the last item before divider or end of list. |
| 248 (setq rest2 (cdr rest2))) | 248 (setq rest2 (cdr rest2))) |
| 249 (setcdr rest2 | 249 (setcdr rest2 |
| 250 (nconc (list (setq menu (list (car rest)))) | 250 (nconc (list (setq menu (list (car rest)))) |
| 251 (cdr rest2))))) | 251 (cdr rest2))))) |
| 252 (setq so-far menu) | 252 (setq so-far menu) |
| 253 (setq rest (cdr rest))))) | 253 (setq rest (cdr rest))))) |
| 254 (if (and item-found (car item-found)) | 254 (if (and item-found (car item-found)) |
| 255 ;; hack the item in place. | 255 ;; hack the item in place. |
| 256 (if menu | 256 (if (or menu (not (eq (car item-found) (car menubar)))) ;If either replacing in submenu, or replacing non-initial top-level item. |
| 257 ;; Isn't it very bad form to use nsubstitute for side effects? | 257 ;; Isn't it very bad form to use nsubstitute for side effects? |
| 258 (nsubstitute new-item (car item-found) menu) | 258 (nsubstitute new-item (car item-found) (or menu menubar)) |
| 259 (setq current-menubar (nsubstitute new-item | 259 (setcar menubar new-item)) |
| 260 (car item-found) | |
| 261 current-menubar))) | |
| 262 ;; OK, we have to add the whole thing... | 260 ;; OK, we have to add the whole thing... |
| 263 ;; if BEFORE is specified, try to add it there. | 261 ;; if BEFORE is specified, try to add it there. |
| 264 (unless menu (setq menu current-menubar)) | 262 (unless menu (setq menu menubar)) |
| 265 (when before | 263 (when before |
| 266 (setq before (car (find-menu-item menu (list before))))) | 264 (setq before (car (find-menu-item menu (list before))))) |
| 267 (let ((rest menu) | 265 (let ((rest menu) |
| 268 (added-before nil)) | 266 (added-before nil)) |
| 269 (while rest | 267 (while rest |
| 273 (setq rest nil added-before t)) | 271 (setq rest nil added-before t)) |
| 274 (setq rest (cdr rest)))) | 272 (setq rest (cdr rest)))) |
| 275 (when (not added-before) | 273 (when (not added-before) |
| 276 ;; adding before the first item on the menubar itself is harder | 274 ;; adding before the first item on the menubar itself is harder |
| 277 (if (and (eq menu menubar) (eq before (car menu))) | 275 (if (and (eq menu menubar) (eq before (car menu))) |
| 278 (setq menu (cons new-item menu) | 276 (let ((old-car (cons (car menubar) (cdr menubar)))) |
| 279 current-menubar menu) | 277 (setcar menubar new-item) |
| 278 (setcdr menubar old-car)) | |
| 280 ;; otherwise, add the item to the end. | 279 ;; otherwise, add the item to the end. |
| 281 (nconc menu (list new-item)))))) | 280 (nconc menu (list new-item)))))) |
| 282 (set-menubar-dirty-flag) | 281 (set-menubar-dirty-flag) |
| 283 new-item)) | 282 new-item)) |
| 284 | 283 |
| 340 PATH is a list of strings which identify the position of the menu item | 339 PATH is a list of strings which identify the position of the menu item |
| 341 in the menu hierarchy. The documentation of `add-submenu' describes | 340 in the menu hierarchy. The documentation of `add-submenu' describes |
| 342 menu paths. | 341 menu paths. |
| 343 FROM-MENU, if provided, means use that instead of `current-menubar' | 342 FROM-MENU, if provided, means use that instead of `current-menubar' |
| 344 as the menu to change." | 343 as the menu to change." |
| 345 (let* ((pair (condition-case nil (find-menu-item (or from-menu | 344 (let* ((menubar (or from-menu current-menubar)) |
| 346 current-menubar) path) | 345 (pair (condition-case nil (find-menu-item menubar path) |
| 347 (error nil))) | 346 (error nil))) |
| 348 (item (car pair)) | 347 (item (car pair)) |
| 349 (parent (or (cdr pair) current-menubar))) | 348 (parent (or (cdr pair) menubar))) |
| 350 (if (not item) | 349 (if (not item) |
| 351 nil | 350 nil |
| 352 ;; the menubar is the only special case, because other menus begin | 351 (if (eq item (car menubar)) ; Deleting first item from a top-level menubar |
| 353 ;; with their name. | 352 (progn |
| 354 (if (eq parent current-menubar) | 353 (setcar menubar (car (cdr menubar))) |
| 355 (setq current-menubar (delete* item parent)) | 354 (setcdr menubar (cdr (cdr menubar)))) |
| 356 (delete* item parent)) | 355 (delete* item parent)) |
| 357 (set-menubar-dirty-flag) | 356 (set-menubar-dirty-flag) |
| 358 item))) | 357 item))) |
| 359 | 358 |
| 360 (defun relabel-menu-item (path new-name) | 359 (defun relabel-menu-item (path new-name) |