Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-menu.el @ 20:859a2309aef8 r19-15b93

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b93
author cvs
date Mon, 13 Aug 2007 08:50:05 +0200
parents 376386a54a3c
children 4103f0995bd7
comparison
equal deleted inserted replaced
19:ac1f612d5250 20:859a2309aef8
1 ;;; Menu related functions and commands 1 ;;; Menu related functions and commands
2 ;;; Copyright (C) 1995 Kyle E. Jones 2 ;;; Copyright (C) 1995, 1997 Kyle E. Jones
3 ;;; 3 ;;;
4 ;;; Folders menu derived from 4 ;;; Folders menu derived from
5 ;;; vm-folder-menu.el 5 ;;; vm-folder-menu.el
6 ;;; v1.10; 03-May-1994 6 ;;; v1.10; 03-May-1994
7 ;;; Copyright (C) 1994 Heiko Muenkel 7 ;;; Copyright (C) 1994 Heiko Muenkel
121 ["Edit" vm-edit-message vm-message-list] 121 ["Edit" vm-edit-message vm-message-list]
122 ["Print" vm-print-message vm-message-list] 122 ["Print" vm-print-message vm-message-list]
123 ["Pipe to Command" vm-pipe-message-to-command vm-message-list] 123 ["Pipe to Command" vm-pipe-message-to-command vm-message-list]
124 "---" 124 "---"
125 ["Burst Message as Digest" (vm-burst-digest "guess") vm-message-list] 125 ["Burst Message as Digest" (vm-burst-digest "guess") vm-message-list]
126 ["Decode MIME" vm-decode-mime-message (vm-menu-can-decode-mime-p)]
126 )))) 127 ))))
127 128
128 (defconst vm-menu-motion-menu 129 (defconst vm-menu-motion-menu
129 '("Motion" 130 '("Motion"
130 ["Page Up" vm-scroll-backward vm-message-list] 131 ["Page Up" vm-scroll-backward vm-message-list]
176 ["Forward Message" vm-forward-message vm-message-list] 177 ["Forward Message" vm-forward-message vm-message-list]
177 ["Resend Message" vm-resend-message vm-message-list] 178 ["Resend Message" vm-resend-message vm-message-list]
178 ["Retry Bounced Message" vm-resend-bounced-message vm-message-list] 179 ["Retry Bounced Message" vm-resend-bounced-message vm-message-list]
179 ["Send Digest (RFC934)" vm-send-rfc934-digest vm-message-list] 180 ["Send Digest (RFC934)" vm-send-rfc934-digest vm-message-list]
180 ["Send Digest (RFC1153)" vm-send-rfc1153-digest vm-message-list] 181 ["Send Digest (RFC1153)" vm-send-rfc1153-digest vm-message-list]
182 ["Send MIME Digest" vm-send-mime-digest vm-message-list]
181 )) 183 ))
182 184
183 (defconst vm-menu-mark-menu 185 (defconst vm-menu-mark-menu
184 '("Mark" 186 '("Mark"
185 ["Next Command Uses Marks..." vm-next-command-uses-marks 187 ["Next Command Uses Marks..." vm-next-command-uses-marks
279 ["Yank Original" vm-menu-yank-original vm-reply-list] 281 ["Yank Original" vm-menu-yank-original vm-reply-list]
280 ["Fill Yanked Message" mail-fill-yanked-message t] 282 ["Fill Yanked Message" mail-fill-yanked-message t]
281 ["Insert Signature" mail-signature t] 283 ["Insert Signature" mail-signature t]
282 ["Insert File..." insert-file t] 284 ["Insert File..." insert-file t]
283 ["Insert Buffer..." insert-buffer t] 285 ["Insert Buffer..." insert-buffer t]
286 "----"
287 "MIME:"
288 "----"
289 [" Attach File..." vm-mime-attach-file vm-send-using-mime]
290 [" Attach MIME File..." vm-mime-attach-mime-file vm-send-using-mime]
291 [" Encode MIME, But Don't Send" vm-mime-encode-composition
292 (and vm-send-using-mime
293 (null (vm-mail-mode-get-header-contents "MIME-Version:")))]
294 [" Preview MIME Before Sending" vm-mime-preview-composition
295 vm-send-using-mime]
284 )))) 296 ))))
297
298 (defconst vm-menu-mime-dispose-menu
299 (let ((title (if (vm-menu-fsfemacs-menus-p)
300 (list "Send MIME body to ..."
301 "Send MIME body to ..."
302 "---"
303 "---")
304 (list "Send MIME body to ..."))))
305 (append
306 title
307 (list ["File" (vm-mime-run-display-function-at-point
308 'vm-mime-send-body-to-file) t]
309 ["Shell Pipeline (display output)"
310 (vm-mime-run-display-function-at-point
311 'vm-mime-pipe-body-to-command) t]
312 ["Shell Pipeline (discard output)"
313 (vm-mime-run-display-function-at-point
314 'vm-mime-pipe-body-to-command-discard-output) t]))))
285 315
286 (defconst vm-menu-url-browser-menu 316 (defconst vm-menu-url-browser-menu
287 (let ((title (if (vm-menu-fsfemacs-menus-p) 317 (let ((title (if (vm-menu-fsfemacs-menus-p)
288 (list "Send URL to ..." 318 (list "Send URL to ..."
289 "Send URL to ..." 319 "Send URL to ..."
367 vm-menu-send-menu 397 vm-menu-send-menu
368 vm-menu-mark-menu 398 vm-menu-mark-menu
369 vm-menu-label-menu 399 vm-menu-label-menu
370 vm-menu-sort-menu 400 vm-menu-sort-menu
371 vm-menu-virtual-menu 401 vm-menu-virtual-menu
372 vm-menu-undo-menu 402 ;; vm-menu-undo-menu
373 vm-menu-dispose-menu 403 vm-menu-dispose-menu
374 "---" 404 "---"
375 "---" 405 "---"
376 vm-menu-help-menu)))) 406 vm-menu-help-menu))))
377 407
417 (defun vm-menu-can-undo-p () 447 (defun vm-menu-can-undo-p ()
418 (save-excursion 448 (save-excursion
419 (vm-check-for-killed-folder) 449 (vm-check-for-killed-folder)
420 (vm-select-folder-buffer) 450 (vm-select-folder-buffer)
421 vm-undo-record-list)) 451 vm-undo-record-list))
452
453 (defun vm-menu-can-decode-mime-p ()
454 (save-excursion
455 (vm-check-for-killed-folder)
456 (vm-select-folder-buffer)
457 (and vm-display-using-mime
458 vm-message-pointer
459 vm-presentation-buffer
460 (not vm-mime-decoded)
461 (not (vm-mime-plain-message-p (car vm-message-pointer))))))
422 462
423 (defun vm-menu-yank-original () 463 (defun vm-menu-yank-original ()
424 (interactive) 464 (interactive)
425 (save-excursion 465 (save-excursion
426 (let ((mlist vm-reply-list)) 466 (let ((mlist vm-reply-list))
506 (vm-easy-menu-define vm-menu-fsfemacs-author-menu (list dummy) nil 546 (vm-easy-menu-define vm-menu-fsfemacs-author-menu (list dummy) nil
507 vm-menu-author-menu) 547 vm-menu-author-menu)
508 ;; url browser menu 548 ;; url browser menu
509 (vm-easy-menu-define vm-menu-fsfemacs-url-browser-menu (list dummy) nil 549 (vm-easy-menu-define vm-menu-fsfemacs-url-browser-menu (list dummy) nil
510 vm-menu-url-browser-menu) 550 vm-menu-url-browser-menu)
551 ;; mime dispose menu
552 (vm-easy-menu-define vm-menu-fsfemacs-mime-dispose-menu
553 (list dummy) nil
554 vm-menu-mime-dispose-menu)
511 ;; block the global menubar entries in the map so that VM 555 ;; block the global menubar entries in the map so that VM
512 ;; can take over the menubar if necessary. 556 ;; can take over the menubar if necessary.
513 (define-key map [rootmenu] (make-sparse-keymap)) 557 (define-key map [rootmenu] (make-sparse-keymap))
514 (define-key map [rootmenu vm] (cons "VM" (make-sparse-keymap "VM"))) 558 (define-key map [rootmenu vm] (cons "VM" (make-sparse-keymap "VM")))
515 (define-key map [rootmenu vm file] 'undefined) 559 (define-key map [rootmenu vm file] 'undefined)
551 ;; menus appear in the opposite order that we 595 ;; menus appear in the opposite order that we
552 ;; define-key them. 596 ;; define-key them.
553 (menu-list 597 (menu-list
554 (if (consp vm-use-menus) 598 (if (consp vm-use-menus)
555 (reverse vm-use-menus) 599 (reverse vm-use-menus)
556 (list 'help nil 'dispose 'undo 'virtual 'sort 600 (list 'help nil 'dispose 'virtual 'sort
557 'label 'mark 'send 'motion 'folder)))) 601 'label 'mark 'send 'motion 'folder))))
558 (while menu-list 602 (while menu-list
559 (if (null (car menu-list)) 603 (if (null (car menu-list))
560 nil;; no flushright support in FSF Emacs 604 nil;; no flushright support in FSF Emacs
561 (aset vec 2 (intern (concat "vm-menubar-" 605 (aset vec 2 (intern (concat "vm-menubar-"
622 (cond ((overlay-get (car o-list) 'vm-url) 666 (cond ((overlay-get (car o-list) 'vm-url)
623 (setq found t) 667 (setq found t)
624 (vm-menu-popup-url-browser-menu event)) 668 (vm-menu-popup-url-browser-menu event))
625 ((setq menu (overlay-get (car o-list) 'vm-header)) 669 ((setq menu (overlay-get (car o-list) 'vm-header))
626 (setq found t) 670 (setq found t)
627 (vm-menu-popup-fsfemacs-menu event menu))) 671 (vm-menu-popup-fsfemacs-menu event menu))
672 ((overlay-get (car o-list) 'vm-mime-layout)
673 (setq found t)
674 (vm-menu-popup-mime-dispose-menu event)))
628 (setq o-list (cdr o-list))) 675 (setq o-list (cdr o-list)))
629 (and (not found) (vm-menu-popup-fsfemacs-menu event)))))) 676 (and (not found) (vm-menu-popup-fsfemacs-menu event))))))
630 677
631 ;; to quiet the byte-compiler 678 ;; to quiet the byte-compiler
632 (defvar vm-menu-fsfemacs-url-browser-menu) 679 (defvar vm-menu-fsfemacs-url-browser-menu)
680 (defvar vm-menu-fsfemacs-mime-dispose-menu)
633 681
634 (defun vm-menu-popup-url-browser-menu (event) 682 (defun vm-menu-popup-url-browser-menu (event)
635 (interactive "e") 683 (interactive "e")
636 (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus) 684 (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus)
637 ;; Must select window instead of just set-buffer because 685 ;; Must select window instead of just set-buffer because
644 ((and (vm-menu-fsfemacs-menus-p) vm-use-menus) 692 ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
645 (set-buffer (window-buffer (posn-window (event-start event)))) 693 (set-buffer (window-buffer (posn-window (event-start event))))
646 (goto-char (posn-point (event-start event))) 694 (goto-char (posn-point (event-start event)))
647 (vm-menu-popup-fsfemacs-menu 695 (vm-menu-popup-fsfemacs-menu
648 event vm-menu-fsfemacs-url-browser-menu)))) 696 event vm-menu-fsfemacs-url-browser-menu))))
697
698 (defun vm-menu-popup-mime-dispose-menu (event)
699 (interactive "e")
700 (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus)
701 ;; Must select window instead of just set-buffer because
702 ;; popup-menu returns before the user has made a
703 ;; selection. This will cause the command loop to
704 ;; resume which might undo what set-buffer does.
705 (select-window (event-window event))
706 (and (event-point event) (goto-char (event-point event)))
707 (popup-menu vm-menu-mime-dispose-menu))
708 ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
709 (set-buffer (window-buffer (posn-window (event-start event))))
710 (goto-char (posn-point (event-start event)))
711 (vm-menu-popup-fsfemacs-menu
712 event vm-menu-fsfemacs-mime-dispose-menu))))
649 713
650 ;; to quiet the byte-compiler 714 ;; to quiet the byte-compiler
651 (defvar vm-menu-fsfemacs-mail-menu) 715 (defvar vm-menu-fsfemacs-mail-menu)
652 (defvar vm-menu-fsfemacs-dispose-popup-menu) 716 (defvar vm-menu-fsfemacs-dispose-popup-menu)
653 (defvar vm-menu-fsfemacs-vm-menu) 717 (defvar vm-menu-fsfemacs-vm-menu)
694 (set-buffer buffer) 758 (set-buffer buffer)
695 (vm-select-folder-buffer)) 759 (vm-select-folder-buffer))
696 (cond ((vm-menu-xemacs-menus-p) 760 (cond ((vm-menu-xemacs-menus-p)
697 (if (null (car (find-menu-item current-menubar '("XEmacs")))) 761 (if (null (car (find-menu-item current-menubar '("XEmacs"))))
698 (set-buffer-menubar vm-menu-vm-menubar) 762 (set-buffer-menubar vm-menu-vm-menubar)
763 ;; copy the current menubar in case it has been changed.
764 (make-local-variable 'vm-menu-vm-menubar)
765 (setq vm-menu-vm-menubar (copy-sequence current-menubar))
699 (set-buffer-menubar (copy-sequence (vm-menu-xemacs-global-menubar))) 766 (set-buffer-menubar (copy-sequence (vm-menu-xemacs-global-menubar)))
700 (condition-case nil 767 (condition-case nil
701 (add-menu-button nil vm-menu-vm-button nil) 768 (add-menu-button nil vm-menu-vm-button nil)
702 (void-function 769 (void-function
703 (add-menu-item nil "VM" 'vm-menu-toggle-menubar t)))) 770 (add-menu-item nil "VM" 'vm-menu-toggle-menubar t))))
704 (vm-menu-set-menubar-dirty-flag) 771 (vm-menu-set-menubar-dirty-flag)
705 (vm-check-for-killed-summary) 772 (vm-check-for-killed-summary)
706 (and vm-summary-buffer 773 (and vm-summary-buffer
707 (vm-menu-toggle-menubar vm-summary-buffer))) 774 (save-excursion
775 (vm-menu-toggle-menubar vm-summary-buffer)))
776 (vm-check-for-killed-presentation)
777 (and vm-presentation-buffer-handle
778 (save-excursion
779 (vm-menu-toggle-menubar vm-presentation-buffer-handle))))
708 ((vm-menu-fsfemacs-menus-p) 780 ((vm-menu-fsfemacs-menus-p)
709 (if (not (eq (lookup-key vm-mode-map [menu-bar]) 781 (if (not (eq (lookup-key vm-mode-map [menu-bar])
710 (lookup-key vm-mode-menu-map [rootmenu vm]))) 782 (lookup-key vm-mode-menu-map [rootmenu vm])))
711 (define-key vm-mode-map [menu-bar] 783 (define-key vm-mode-map [menu-bar]
712 (lookup-key vm-mode-menu-map [rootmenu vm])) 784 (lookup-key vm-mode-menu-map [rootmenu vm]))
717 (vm-menu-set-menubar-dirty-flag)))) 789 (vm-menu-set-menubar-dirty-flag))))
718 790
719 (defun vm-menu-install-menubar () 791 (defun vm-menu-install-menubar ()
720 (cond ((vm-menu-xemacs-menus-p) 792 (cond ((vm-menu-xemacs-menus-p)
721 (setq vm-menu-vm-menubar (vm-menu-make-xemacs-menubar)) 793 (setq vm-menu-vm-menubar (vm-menu-make-xemacs-menubar))
722 (set-buffer-menubar vm-menu-vm-menubar)) 794 (set-buffer-menubar vm-menu-vm-menubar)
795 (run-hooks 'vm-menu-setup-hook)
796 (setq vm-menu-vm-menubar current-menubar))
723 ((and (vm-menu-fsfemacs-menus-p) 797 ((and (vm-menu-fsfemacs-menus-p)
724 ;; menus only need to be installed once for FSF Emacs 798 ;; menus only need to be installed once for FSF Emacs
725 (not (fboundp 'vm-menu-undo-menu))) 799 (not (fboundp 'vm-menu-undo-menu)))
726 (vm-menu-initialize-vm-mode-menu-map) 800 (vm-menu-initialize-vm-mode-menu-map)
727 (define-key vm-mode-map [menu-bar] 801 (define-key vm-mode-map [menu-bar]
748 822
749 (defun vm-menu-install-mail-mode-menu () 823 (defun vm-menu-install-mail-mode-menu ()
750 (cond ((vm-menu-xemacs-menus-p) 824 (cond ((vm-menu-xemacs-menus-p)
751 ;; mail-mode doesn't have mode-popup-menu bound to 825 ;; mail-mode doesn't have mode-popup-menu bound to
752 ;; mouse-3 by default. fix that. 826 ;; mouse-3 by default. fix that.
753 (define-key vm-mail-mode-map 'button3 'popup-mode-menu) 827 (if vm-popup-menu-on-mouse-3
828 (define-key vm-mail-mode-map 'button3 'popup-mode-menu))
754 ;; put menu on menubar also. 829 ;; put menu on menubar also.
755 (if (vm-menu-xemacs-global-menubar) 830 (if (vm-menu-xemacs-global-menubar)
756 (progn 831 (progn
757 (set-buffer-menubar 832 (set-buffer-menubar
758 (copy-sequence (vm-menu-xemacs-global-menubar))) 833 (copy-sequence (vm-menu-xemacs-global-menubar)))
762 ;; I'd like to do this, but the result is a combination 837 ;; I'd like to do this, but the result is a combination
763 ;; of the Emacs and VM Mail menus glued together. 838 ;; of the Emacs and VM Mail menus glued together.
764 ;; Poorly. 839 ;; Poorly.
765 ;;(define-key vm-mail-mode-map [menu-bar mail] 840 ;;(define-key vm-mail-mode-map [menu-bar mail]
766 ;; (cons "Mail" vm-menu-fsfemacs-mail-menu)) 841 ;; (cons "Mail" vm-menu-fsfemacs-mail-menu))
767 (define-key vm-mail-mode-map [down-mouse-3] 842 (if vm-popup-menu-on-mouse-3
768 'vm-menu-popup-mode-menu)))) 843 (define-key vm-mail-mode-map [down-mouse-3]
844 'vm-menu-popup-mode-menu)))))
769 845
770 (defun vm-menu-install-menus () 846 (defun vm-menu-install-menus ()
771 (cond ((consp vm-use-menus) 847 (cond ((consp vm-use-menus)
772 (vm-menu-install-vm-mode-menu) 848 (vm-menu-install-vm-mode-menu)
773 (vm-menu-install-menubar) 849 (vm-menu-install-menubar)